How to subset data in networkD3 on Shiny?

Question

Here is a reproducible example:

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) 

What I want to do is letting the user see only the plots of different Teams as in my example via a selectInput or similar.

I had come across the same issue when I was using visNetwork and managed to solve it by using this trick:

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

and the way of using selectInput as below would work perfectly with that:

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)

However with networkD3, I guess something goes wrong with the interpretation of the index order of the nodes following the subset and as you can also see, I get my selectInput with my Teams but when I choose one, it returns an empty plot.

I also tried to shape-shift the solution with reactive here for my case, but it didn't work either:

Create shiny app with sankey diagram that reacts to selectinput

Is it technically not possible to do this in networkD3, or how close was I to the solution?

Thanks!

Answer 1

Per your comment on this question: Create shiny app with sankey diagram that reacts to selectinput, here's the solution from the app in that question while using strings as factors and reactive objects.

The code wraps everything in a reactive object and relies on the strings as factors in the original data frame. Node and link data frames follow from there. The trick is to filter the node prior to converting the strings to factors so the link references and the JavaScript can use a consistent node index.

Code is here:

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)

Answer 2

Here is one strategy for subsetting the nodes, then subsetting the links to only those that start and end at a node within the subset of nodes, then reindexes the links data to reflect the new position of the nodes in the subset nodes data frame.

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