来自 networkD3 的 sankeyNetworkOutput 的反应高度 [英] Reactive height for sankeyNetworkOutput from networkD3
问题描述
我有一个 Shiny 仪表板，它显示来自 networkD3 包的 sankeyNetwork.我正在服务器上的 renderSankeyNetwork 函数内创建 sankeyNetwork，然后使用 sankeyNetworkOutput 在 ui 上调用它.我想让创建的 sankeynetwork 的高度取决于我创建的高度值.
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.
我尝试使用带有 uiOutput 的 renderUI 在服务器上运行 sankeyNetworkOutput，但它似乎不起作用.仪表板以其他方式工作，但没有 sankeynetwork 应该在的地方.我相信这可能与 uiOutput 不能很好地与 renderSankeyNetwork 配合使用的事实有关.
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.
下面是两段代码，都应该是一个合适的reprex.第一个显示仪表板如何在没有动态高度的情况下工作.后者是我尝试使用renderUI+uiOutput.我研究了其他一些关于如何去做的想法，但没有找到任何有用的东西.
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.
工作版本:
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 版本:
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)
推荐答案
你就快到了:
您必须为您的网络和 renderUI 输出定义单独的输出名称，并且您必须提供 height 参数作为字符:
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)
这篇关于来自 networkD3 的 sankeyNetworkOutput 的反应高度的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
