问题
I have a Shiny dashboard that is displaying a sankeyNetwork from the networkD3 package. I'm creating the sankeyNetwork inside of a renderSankeyNetwork function on the server and then calling it on the ui with sankeyNetworkOutput. I'd like to make the height of the created sankeynetwork be dependent on a height value I've created.
I tried using renderUI with uiOutput to run the sankeyNetworkOutput on the server, but it doesn't seem to be working. The dashboard works otherwise but there is nothing where the sankeynetwork is supposed to be. I belive this is likely to do with the fact uiOutput doens't work well with renderSankeyNetwork.
Below is two chunks of code, both should be a proper reprex. The first shows how the dashboard works without having a dynamic height. The latter is my attempt to use renderUI+uiOutput. I looked into a few other ideas for how to do it but didn't have any luck finding anything useful.
Any ideas? Thanks in advance.
Working version:
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)
renderUI + uiOutput version:
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)
回答1:
You were almost there:
You'll have to define separate output names for your network and the renderUI output and you have to provide the height argument as character:
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)
来源：https://stackoverflow.com/questions/58208904/reactive-height-for-sankeynetworkoutput-from-networkd3