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

【问题标题】：How to subset data in networkD3 on Shiny?如何在 Shiny 上对 networkD3 中的数据进行子集化？
【发布时间】：2020-05-23 22:11:44
【问题描述】：

这是一个可重现的例子：

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)

我想要做的是让用户只看到不同 Teams 的图，就像在我的示例中通过 selectInput 或类似的一样。

我在使用 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 中技术上是否不可能做到这一点，或者我离解决方案有多近？

谢谢！

【问题讨论】：

链接和节点数据框应该是连接的（概念上），所以你不应该修改一个而不修改另一个。当您从节点数据框中删除节点时，链接数据框指的是不再存在的节点。
我认为具体示例可能效果不佳，因为我看到了您所描述的问题，但是如果我附加新数据，我可以创建一个排除的selectInput没有问题的新组。您可能需要使用更丰富的示例数据集。
CJ，你能想到任何其他方法吗，可能是同时修改两者，或者使用另一个 Shiny/R 子集/选择技巧？ Hack-R，谢谢，实际上我有一个非常大的数据集，但从技术上讲，它们都应该以与我的小示例完全相同的格式保存在一对节点/链接文件中，我应该从中子集某些“团队”并成为只需更改我的选择即可查看另一个。
是的，完全正确。您应该修改两者以使它们仍然同步。大概与您创建原始配对的方式类似。
我建议至少在开发阶段将闪亮排除在外。它与问题无关，会导致分心。在普通的 R 代码中，加载您的数据并绘制一个 forceNetwork。然后弄清楚如何对数据进行子集化并为此正确绘制 forceNetwork。完成后，您实际上可以将该代码复制粘贴到任何闪亮的应用程序中，选择输入只是提供必要的信息来子集您的数据。

标签： r shiny htmlwidgets networkd3

【解决方案1】：

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

代码将所有内容包装在反应对象中，并依赖字符串作为原始数据框中的因素。节点和链接数据帧从那里跟随。诀窍是在将字符串转换为因子之前过滤节点，以便链接引用和 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)

【讨论】：

【解决方案2】：

这是对节点进行子集化的一种策略，然后将链接子集化为仅在节点子集中的某个节点处开始和结束的链接，然后重新索引链接数据以反映节点在子集节点数据中的新位置框架。

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)


MyNodes$link_id <- 1:nrow(MyNodes) - 1
subnodes <- MyNodes[MyNodes$Team == "Team2", ]

sublinks <- MyLinks[MyLinks$source %in% subnodes$link_id & MyLinks$target %in% subnodes$link_id, ]
sublinks$source <- match(sublinks$source, subnodes$link_id) - 1
sublinks$target <- match(sublinks$target, subnodes$link_id) - 1

forceNetwork(Links = sublinks, Nodes = subnodes,
             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)


MyNodes
#>   name size  Team  group link_id
#> 1    A    1 Team1 Group1       0
#> 2    B    1 Team1 Group1       1
#> 3    C    1 Team1 Group2       2
#> 4    D    1 Team1 Group2       3
#> 5    E    1 Team2 Group1       4
#> 6    F    1 Team2 Group1       5

MyLinks
#>   source target value
#> 1      0      1    10
#> 2      2      3    50
#> 3      4      5    20

subnodes
#>   name size  Team  group link_id
#> 5    E    1 Team2 Group1       4
#> 6    F    1 Team2 Group1       5

sublinks
#>   source target value
#> 3      0      1    20

【讨论】：