Реактивная высота для sankeyNetworkOutput из сети D3 - PullRequest
Новая
       61

Реактивная высота для sankeyNetworkOutput из сети D3

1 голос
/ 02 октября 2019

У меня есть Shiny dashboard, которая отображает sankeyNetwork из пакета networkD3. Я создаю sankeyNetwork внутри функции renderSankeyNetwork на сервере, а затем вызываю ее через пользовательский интерфейс с помощью sankeyNetworkOutput. Я хотел бы, чтобы высота создаваемой sankeynetwork зависела от значения высоты, которое я создал.

Я пытался использовать renderUI с uiOutput для запуска sankeyNetworkOutput на сервере, но, похоже, это не так. работатьПанель управления работает иначе, но там, где должна быть сеть санкейнов, нет ничего. Я верю, что это, скорее всего, связано с тем, что uiOutput не очень хорошо работает с renderSankeyNetwork.

Ниже приведены два фрагмента кода, оба должны быть правильными. Первый показывает, как приборная панель работает без динамической высоты. Последняя моя попытка использовать 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)

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)

1 Ответ

2 голосов
/ 09 октября 2019

Вы были почти там:

Вам нужно будет определить отдельные имена выходов для вашей сети и выход 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)
...