桑基网络从网络D3输出的反应高度

Question

我有一个闪亮的仪表板，它显示来自networkD3软件包的sankeyNetwork。我在服务器上的渲染SankeyNetwork函数中创建sankeyNetwork，然后使用sankeyNetworkOutput在UI上调用它。我想使创建的桑基网络的高度取决于我创建的高度值。

我尝试使用带有uiOutput的renderUI在服务器上运行sankeyNetworkOutput，但它似乎不起作用。仪表板以其他方式工作，但桑基网络应该在哪里。我相信这可能与uiOutput不能很好地与renderSankeyNetwork配合有关。

下面是两个代码块，两者都应该是一个适当的reprex。第一个显示仪表板如何在没有动态高度的情况下工作。后者是我尝试使用 renderUI+uiOutput。我研究了其他一些关于如何做到这一点的想法，但没有找到任何有用的东西。

有什么想法吗？提前谢谢。

工作版本：

library(shiny)
ui <- fluidPage(
selectInput(inputId = "plot",
label   = "plot",
choices = c("plota", "plotb")),
sankeyNetworkOutput("diagram")
# uiOutput("diagram")
)
server <- function(input, output) {
dat <- data.frame(plot   = c("plota", "plota", "plotb", "plotb", "plotb"),
start  = c("a", "b", "a", "b", "c"),
finish = c("x", "x", "y", "y", "z"),
count  = c(12, 4, 5, 80, 10),
height = c("200px", "200px", "400px", "400px", "400px"))
temp_dat <- reactive({
filter(dat, plot == input$plot)
})
links <- reactive({
temp_dat <- temp_dat()
data.frame(source = temp_dat$start,
target = temp_dat$finish,
value  = temp_dat$count)
})
nodes <- reactive({
temp_links_1 <- links()
data.frame(name = c(as.character(temp_links_1$source),
as.character(temp_links_1$target))#,
) %>%
unique()
})
links2 <- reactive({
temp_links <- links()
temp_nodes <- nodes()
temp_links$IDsource <- match(temp_links$source, temp_nodes$name) - 1
temp_links$IDtarget <- match(temp_links$target, temp_nodes$name) - 1
temp_links
})
output$diagram <- renderSankeyNetwork({
sankeyNetwork(
Links       = links2(),
Nodes       = nodes(),
Source      = "IDsource",
Target      = "IDtarget",
Value       = "value",
NodeID      = "name",
sinksRight  = FALSE,
fontSize    = 13
)
})
# output$diagram <- renderUI({
#     temp <- temp_dat()
#     sankeyNetworkOutput("diagram", height = c(unique(temp$height)[1]))
# })
}
shinyApp(ui = ui, server = server)

渲染UI + ui输出版本：

library(shiny)
ui <- fluidPage(
selectInput(inputId = "plot",
label   = "plot",
choices = c("plota", "plotb")),
# sankeyNetworkOutput("diagram")
uiOutput("diagram")
)
server <- function(input, output) {
dat <- data.frame(plot   = c("plota", "plota", "plotb", "plotb", "plotb"),
start  = c("a", "b", "a", "b", "c"),
finish = c("x", "x", "y", "y", "z"),
count  = c(12, 4, 5, 80, 10),
height = c("200px", "200px", "400px", "400px", "400px"))
temp_dat <- reactive({
filter(dat, plot == input$plot)
})
links <- reactive({
temp_dat <- temp_dat()
data.frame(source = temp_dat$start,
target = temp_dat$finish,
value  = temp_dat$count)
})
nodes <- reactive({
temp_links_1 <- links()
data.frame(name = c(as.character(temp_links_1$source),
as.character(temp_links_1$target))#,
) %>%
unique()
})
links2 <- reactive({
temp_links <- links()
temp_nodes <- nodes()
temp_links$IDsource <- match(temp_links$source, temp_nodes$name) - 1
temp_links$IDtarget <- match(temp_links$target, temp_nodes$name) - 1
temp_links
})
# output$diagram <- renderSankeyNetwork({
#     sankeyNetwork(
#         Links       = links2(),
#         Nodes       = nodes(),
#         Source      = "IDsource",
#         Target      = "IDtarget",
#         Value       = "value",
#         NodeID      = "name",
#         sinksRight  = FALSE,
#         fontSize    = 13
#     )
# })
output$diagram <- renderUI({
temp <- temp_dat()
sankeyNetworkOutput("diagram", height = c(unique(temp$height)[1]))
})
}
shinyApp(ui = ui, server = server)

Answer 1

你快到了：

您必须为网络和renderUI输出定义单独的输出名称，并且必须提供height参数作为字符：

library(shiny)
library(networkD3)
library(dplyr)
ui <- fluidPage(
selectInput(inputId = "plot",
label   = "plot",
choices = c("plota", "plotb")),
# sankeyNetworkOutput("diagram")
uiOutput("diagram")
)
server <- function(input, output) {
dat <- data.frame(plot   = c("plota", "plota", "plotb", "plotb", "plotb"),
start  = c("a", "b", "a", "b", "c"),
finish = c("x", "x", "y", "y", "z"),
count  = c(12, 4, 5, 80, 10),
height = c("200px", "200px", "400px", "400px", "400px"))
temp_dat <- reactive({
filter(dat, plot == input$plot)
})
links <- reactive({
temp_dat <- req(temp_dat())
data.frame(source = temp_dat$start,
target = temp_dat$finish,
value  = temp_dat$count)
})
nodes <- reactive({
temp_links_1 <- req(links())
data.frame(name = c(as.character(temp_links_1$source),
as.character(temp_links_1$target))#,
) %>%
unique()
})
links2 <- reactive({
temp_links <- req(links())
temp_nodes <- req(nodes())
temp_links$IDsource <- match(temp_links$source, temp_nodes$name) - 1
temp_links$IDtarget <- match(temp_links$target, temp_nodes$name) - 1
temp_links
})
output$mySankeyNetwork <- renderSankeyNetwork({
sankeyNetwork(
Links       = links2(),
Nodes       = nodes(),
Source      = "IDsource",
Target      = "IDtarget",
Value       = "value",
NodeID      = "name",
sinksRight  = FALSE,
fontSize    = 13
)
})
output$diagram <- renderUI({
temp <- temp_dat()
sankeyNetworkOutput("mySankeyNetwork", height = as.character(unique(temp$height)[1]))
})
}
shinyApp(ui = ui, server = server)