r - 如何在 Shiny 上对 networkD3 中的数据进行子集化？

Question

这是一个可重现的例子:

library(networkD3)

MyNodes<-data.frame(name= c("A", "B", "C", "D", "E", "F"),
                    size= c("1","1","1","1","1","1"),
        Team= c("Team1", "Team1", "Team1", "Team1", "Team2", "Team2"),
        group= c("Group1", "Group1", "Group2", "Group2", "Group1", "Group1"))

MyLinks<-data.frame(source= c("0","2","4"),
                    target= c("1","3","5"),
                    value= c("10","50","20"))

forceNetwork(Links = MyLinks, Nodes = MyNodes,
             Source = "source",
             Target = "target", Value = "value", NodeID = "name",
             Nodesize = 'size', radiusCalculation = " Math.sqrt(d.nodesize)+6",
             Group = "group", linkWidth = 1, linkDistance = JS("function(d){return d.value * 1}"), opacity = 5, zoom = T, legend = T, bounded = T) 

我想做的是让用户通过 selectInput 或类似方式只看到不同Team 的图表，就像我的示例中那样。

我在使用 visNetwork 时遇到了同样的问题，并通过使用这个技巧设法解决了它:

MyNodes[MyNodes$"Team"=="Team2",]

下面使用 selectInput 的方式将与此完美配合:

library(shiny)
library(networkD3)

server <- function(input, output) {
  output$force <- renderForceNetwork({
    forceNetwork(Links = MyLinks, Nodes = MyNodes[MyNodes$"Team"==input$TeamSelect,],
                 Source = "source",
                 Target = "target", Value = "value", NodeID = "name",
                 Nodesize = 'size', radiusCalculation = " Math.sqrt(d.nodesize)+6",
                 Group = "group", linkWidth = 1, linkDistance = JS("function(d){return d.value * 1}"), opacity = 5, zoom = T, legend = T, bounded = T) 
  })}

ui <- fluidPage(
  selectInput("TeamSelect", "Choose a Team:", MyNodes$Team, selectize=TRUE),
  forceNetworkOutput("force"))

shinyApp(ui = ui, server = server)

但是对于 networkD3，我猜子集后面节点的索引顺序的解释出了点问题，正如您也看到的，我用 selectInput>团队但是当我选择一个团队时，它会返回一个空图。

对于我的案例，我还尝试在此处使用响应式(Reactive)改变解决方案，但它也没有用:

Create shiny app with sankey diagram that reacts to selectinput

从技术上讲，在 networkD3 中无法做到这一点，或者我离解决方案有多近？

谢谢!

Answer 1

根据您对此问题的评论:Create shiny app with sankey diagram that reacts to selectinput ，这是应用程序在该问题中的解决方案，同时使用字符串作为因子和 react 对象。

代码将所有内容包装在一个 react ​​对象中，并依赖字符串作为原始数据帧中的因素。节点和链接数据帧从那里开始。诀窍是在将字符串转换为因子之前过滤节点，以便链接引用和 JavaScript 可以使用一致的节点索引。

代码在这里:

library(shiny)
library(networkD3)
library(dplyr)
ui <- fluidPage(
  selectInput(inputId = "school",
              label   = "School",
              choices =  c("alpha", "echo")),
  selectInput(inputId = "school2",
              label   = "School2",
              choices =  c("bravo", "charlie", "delta", "foxtrot"),
              selected = c("bravo", "charlie"),
              multiple = TRUE),

  sankeyNetworkOutput("diagram")
)

server <- function(input, output) {

  dat <- reactive({
    data.frame(schname = c("alpha", "alpha", "alpha", "echo"),
                    next_schname = c("bravo", "charlie", "delta", "foxtrot"),
                    count = c(1, 5, 3, 4),
                    stringsAsFactors = FALSE) %>%
      filter(next_schname %in% input$school2) %>%
      mutate(schname = factor(schname),
             next_schname = factor(next_schname))
  })

  links <- reactive({
    data.frame(source = dat()$schname,
                      target = dat()$next_schname,
                      value  = dat()$count)
  })

  nodes <- reactive({
    data.frame(name = c(as.character(links()$source),
                               as.character(links()$target)) %>%
                        unique) 
    })



  links2 <-reactive({
    links <- links()
    links$IDsource <- match(links$source, nodes()$name) - 1
    links$IDtarget <- match(links$target, nodes()$name) - 1

    links %>%
      filter(source == input$school)
  })


  output$diagram <- renderSankeyNetwork({
    sankeyNetwork(
      Links = links2(),
      Nodes = nodes(),
      Source = "IDsource",
      Target = "IDtarget",
      Value = "value",
      NodeID = "name",
      sinksRight = FALSE
    )
  })
}

shinyApp(ui = ui, server = server)