4

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!

CJ Yetman
  • 8,373
  • 2
  • 24
  • 56
FatihSarigol
  • 647
  • 7
  • 14
  • 1
    The links and nodes data frames are supposed to be connected (conceptually), so you shouldn’t modify one without modifying the other. When you drop nodes from the nodes data frame, the links data frame is referring to nodes that don’t exist anymore. – CJ Yetman May 23 '20 at 22:35
  • 1
    I think the specific example may not work well because I see the problem you're describing, however if I append new data I can make a `selectInput` that *excludes* the new group with no problems. You may need a richer example data set to work with. – Hack-R May 23 '20 at 22:38
  • CJ, can you think of any other way of doing it, perhaps by modifying both at the same time, or by using another Shiny/R subset/selection trick? Hack-R, thanks, I have a very large dataset actually, but it all should technically stay in a single pair of nodes/links file in exactly the same format as in my small example from which I should subset certain "teams" and be able to look at the other one just by changing my selection. – FatihSarigol May 23 '20 at 23:16
  • 1
    Yes, exactly. You should modify both so that they’re still in sync. Presumably in a similar way to how you created the original pair. – CJ Yetman May 24 '20 at 05:16
  • Adding a `Team` column to `MyLinks` file and having two `selectInput`s was one thought I already had but wouldn't be nice for the web app; even with that, I noticed `Team1` works because it's index starts from 0, but `Team2` gives again an empty plot. I guess I'd need a function that can interact with `selectInput` and create a new `MyLinks` file on the go for each `Team` selection by numbering them starting from 0. But I guess even that would hit the `arguments imply differing number of rows: 0, 1` error of Shiny, as it just did for me :/ – FatihSarigol May 25 '20 at 08:28
  • 1
    I would suggest taking shiny out of the equation, at least in the development phase. It’s irrelevant to the problem and causes distraction. In normal R code, load your data and plot a forceNetwork. Then figure out how to subset your data and correctly plot a forceNetwork for that. Once you’ve got that down, you can practically copy-paste that code into any shiny application, which the select input just providing the necessary info to subset your data. – CJ Yetman May 25 '20 at 19:03

2 Answers2

3

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)
Ryan Morton
  • 2,605
  • 1
  • 16
  • 19
1

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
CJ Yetman
  • 8,373
  • 2
  • 24
  • 56