来自 networkD3 的 sankeyNetworkOutput 的反应高度

Question

我有一个闪亮的仪表板，它显示来自 networkD3 包的 sankeyNetwork。我在服务器上的 renderSankeyNetwork 函数内部创建 sankeyNetwork，然后使用 sankeyNetworkOutput 在 ui 上调用它。我想让创建的 sankeynetwork 的高度取决于我创建的高度值。

我尝试将 renderUI 与 uiOutput 一起使用到运行服务器上的 sankeyNetworkOutput，但它似乎不起作用。仪表板以其他方式工作，但 sankeynetwork 应该在的地方没有任何东西。我相信这可能与 uiOutput 与 renderSankeyNetwork 配合不佳这一事实有关。

下面是两段代码，都应该是正确的表示。第一个显示仪表板如何在没有动态高度的情况下工作。后者是我尝试使用renderUI+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)

renderUI + 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)

来自 networkD3 的 sankeyNetworkOutput 的反应高度

Reactive height for sankeyNetworkOutput from networkD3

shiny

sankey-diagram

networkd3

reactive