How to make numbers reactive in Sankey Plot from networkD3

I would like to be able to click each number on the plot and then display a pop-up table with the patients/subjects information that belong to that set of numbers. That is, I would like to insert Shiny.onInputChange('clickedNode', d.cnt) in the clickJS JavaScript that will return the appropriate node value (in this case Mild_1, Mild_2, Severe_4, etc.).

library(shiny)
library(networkD3)
library(shinydashboard)
library(dplyr)
library(plyr)

### create sample data
vis <- c("Baseline","Week2", "Week4", "Week6")
grade <- c("Mild","Moderate","Severe")
rand1 <- c(22,44,66)
rand2 <- c(33,58,75,88)
rand3 <- c(3,31)
rand4 <- c(46,55)

df <- data.frame(subjid = c(), visit = c(), score = c(), row = c())

for (i in 1:24){
  for (j in 1:4){
    k = i%%3
    subjid = i
    visit = vis[j]
    score = grade[k+1]
    row = i
    df2 <- data.frame(subjid = subjid, visit = visit, score = score, row = row)
    df <- rbind(df,df2)
  }
}

df <- df %>% dplyr::mutate(score = case_when(row_number() %in% rand1 ~ "Absent",
                                             row_number() %in% rand2 ~ "Severe",
                                             row_number() %in% rand3 ~ "Mild",
                                             row_number() %in% rand4 ~ "Moderate",
                                             TRUE ~ score))


df2 <- df %>% 
  group_by(subjid) %>% 
  dplyr::mutate(column = match(visit,vis), source = score) %>% 
  dplyr::mutate(target = lead(source, order_by = column)) %>%  # get target from following node in row
  ungroup() %>% 
  dplyr::filter(!is.na(target))  # remove links from last column in original data

df3 <-
  df2 %>%
  dplyr::mutate(source = paste0(source, '_', column)) %>%
  dplyr::mutate(target = paste0(target, '_', column + 1)) %>%
  dplyr::select(source, target) 
    
links <- plyr::count(df3) %>% dplyr::rename(value=freq)


nodes <- data.frame(name = unique(c(links$source, links$target)))
nodes$label <- sub('_[0-9]*$', '', nodes$name) # remove column id from node label

links$source_id <- match(links$source, nodes$name) - 1  ### Convert the "source" and "target" vectors in the links data frame to be the 0-based-index of the node in the nodes data frame. 
links$target_id <- match(links$target, nodes$name) - 1

mycolors <- c("#7d3945", "#e0677b", "#244457","#01B0F0")

nodes_lst <- unique(nodes$label)

nodes <- nodes %>% 
  dplyr::mutate(color = mycolors[match(nodes$label,nodes_lst)])

colors <- paste(unique(nodes$color), collapse = '", "')
colorJS <- paste('d3.scaleOrdinal(["', colors, '"])')

nodes_cnt <- df %>% 
  group_by(subjid) %>% 
  dplyr::mutate(column = match(visit,vis), source = score) %>% 
  ungroup() %>% 
  group_by(column) %>% 
  dplyr::mutate(totalv = n()) %>% 
  mutate(source = paste0(source, '_', column)) %>% 
  group_by(source,totalv) %>% 
  dplyr::summarise(cnt = n()) %>% 
  dplyr::mutate(perc = round(100*cnt/totalv, 2)) %>% 
  dplyr::select(-totalv)

nodes_cnt <- nodes_cnt[order(match(nodes_cnt$source,nodes$name)),]


clickJS <- '
function(el, x) {
  d3.select(el).selectAll(".node text")
  .text(d => d.name + " (" + d.cnt + ", " + d.perc + "%)")
}
'
###  not sure where to put Shiny.onInputChange('clickedNode', d.cnt) in the above js
###  d.cnt should be clickable and return "Mild_1", "Moderate_2", "Severe_4", etc. value in input$clickedNode, 
###  depending on which number was clicked.

### append two or more dataframe columns
cbindPad <- function(...){
  args <- list(...)
  n <- sapply(args,nrow)
  mx <- max(n)
  pad <- function(x, mx){
    if (nrow(x) < mx){
      nms <- colnames(x)
      padTemp <- matrix(NA, mx - nrow(x), ncol(x))
      colnames(padTemp) <- nms
      if (ncol(x)==0) {
        return(padTemp)
      } else {
        return(rbind(x,padTemp))
      }
    }
    else{
      return(x)
    }
  }
  rs <- lapply(args,pad,mx)
  return(do.call(cbind,rs))
}

ui <- dashboardPage(
  dashboardHeader(
  ),
  dashboardSidebar(disable = TRUE),
  dashboardBody(
    
      sankeyNetworkOutput("simple")
    
  )
)

server <- function(input, output,session) {
  
  output$simple <- renderSankeyNetwork({
    sn <- sankeyNetwork(Links = links, Nodes = nodes, 
                        Source = 'source_id', Target = 'target_id', fontSize = 16,
                        colourScale = colorJS,
                        Value = 'value', NodeID = 'label')
    
   
    ###  This next part adds the new data to the widget sn.
    sn$x$nodes <- cbindPad(sn$x$nodes,nodes_cnt)

    # sn$x$nodes <- right_join(sn$x$nodes, nodes_cnt, by = c("name" = "source"))
    
    ### This final element adds the value and the percentages to the source and destination node labels.
    
    sn <- htmlwidgets::onRender(sn, clickJS)
    
    # return the result
    sn
  })
  
  # observe({print(names(input))})
  
}
shinyApp(ui = ui, server = server)

Solution

I would like to insert Shiny.onInputChange('clickedNode', d.cnt) in the clickJS JavaScript that will return the appropriate node value (in this case Mild_1, Mild_2, Severe_4, etc.).

You can return all the node info you added like name /count / percentage by sending it over to an observable event using a JSON format. This can then be read inside the observer and rendered as a Datatable below. I also changed the cursor style of the nodes to indicated that they are clickable.

For underlined blue text

Add the following to your jsCode in onRender

d3.selectAll(".node text").text(d => d.name + " (" + d.cnt + ", " + d.perc + "%)")
          .style("fill", "blue")
          .style("text-decoration", "underline")

Code

library(shiny)
library(networkD3)
library(shinydashboard)
library(dplyr)
library(plyr)
library(DT)

### create sample data
vis <- c("Baseline","Week2", "Week4", "Week6")
grade <- c("Mild","Moderate","Severe")
rand1 <- c(22,44,66)
rand2 <- c(33,58,75,88)
rand3 <- c(3,31)
rand4 <- c(46,55)

df <- data.frame(subjid = c(), visit = c(), score = c(), row = c())

for (i in 1:24){
  for (j in 1:4){
    k = i%%3
    subjid = i
    visit = vis[j]
    score = grade[k+1]
    row = i
    df2 <- data.frame(subjid = subjid, visit = visit, score = score, row = row)
    df <- rbind(df,df2)
  }
}

df <- df %>% dplyr::mutate(score = case_when(row_number() %in% rand1 ~ "Absent",
                                             row_number() %in% rand2 ~ "Severe",
                                             row_number() %in% rand3 ~ "Mild",
                                             row_number() %in% rand4 ~ "Moderate",
                                             TRUE ~ score))


df2 <- df %>% 
  group_by(subjid) %>% 
  dplyr::mutate(column = match(visit,vis), source = score) %>% 
  dplyr::mutate(target = lead(source, order_by = column)) %>%  # get target from following node in row
  ungroup() %>% 
  dplyr::filter(!is.na(target))  # remove links from last column in original data

df3 <-
  df2 %>%
  dplyr::mutate(source = paste0(source, '_', column)) %>%
  dplyr::mutate(target = paste0(target, '_', column + 1)) %>%
  dplyr::select(source, target) 

links <- plyr::count(df3) %>% dplyr::rename(value=freq)


nodes <- data.frame(name = unique(c(links$source, links$target)))
nodes$label <- sub('_[0-9]*$', '', nodes$name) # remove column id from node label

links$source_id <- match(links$source, nodes$name) - 1  ### Convert the "source" and "target" vectors in the links data frame to be the 0-based-index of the node in the nodes data frame. 
links$target_id <- match(links$target, nodes$name) - 1

mycolors <- c("#7d3945", "#e0677b", "#244457","#01B0F0")

nodes_lst <- unique(nodes$label)

nodes <- nodes %>% 
  dplyr::mutate(color = mycolors[match(nodes$label,nodes_lst)])

colors <- paste(unique(nodes$color), collapse = '", "')
colorJS <- paste('d3.scaleOrdinal(["', colors, '"])')

nodes_cnt <- df %>% 
  group_by(subjid) %>% 
  dplyr::mutate(column = match(visit,vis), source = score) %>% 
  ungroup() %>% 
  group_by(column) %>% 
  dplyr::mutate(totalv = n()) %>% 
  mutate(source = paste0(source, '_', column)) %>% 
  group_by(source,totalv) %>% 
  dplyr::summarise(cnt = n()) %>% 
  dplyr::mutate(perc = round(100*cnt/totalv, 2)) %>% 
  dplyr::select(-totalv)

nodes_cnt <- nodes_cnt[order(match(nodes_cnt$source,nodes$name)),]


clickJS <- '
function(el, x) {
  d3.select(el).selectAll(".node text")
  .text(d => d.name + " (" + d.cnt + ", " + d.perc + "%)")
}
'
###  not sure where to put Shiny.onInputChange('clickedNode', d.cnt) in the above js
###  d.cnt should be clickable and return "Mild_1", "Moderate_2", "Severe_4", etc. value in input$clickedNode, 
###  depending on which number was clicked.

### append two or more dataframe columns
cbindPad <- function(...){
  args <- list(...)
  n <- sapply(args,nrow)
  mx <- max(n)
  pad <- function(x, mx){
    if (nrow(x) < mx){
      nms <- colnames(x)
      padTemp <- matrix(NA, mx - nrow(x), ncol(x))
      colnames(padTemp) <- nms
      if (ncol(x)==0) {
        return(padTemp)
      } else {
        return(rbind(x,padTemp))
      }
    }
    else{
      return(x)
    }
  }
  rs <- lapply(args,pad,mx)
  return(do.call(cbind,rs))
}



ui <- dashboardPage(
  dashboardHeader(title = "Interactive Sankey Network"),
  dashboardSidebar(disable = TRUE),
  dashboardBody(
    box(width = 12,
        div("Click on the Nodes for more Info!"),
        sankeyNetworkOutput("simple"),
        DTOutput("node_details")
    )
  )
)


server <- function(input, output,session) {
  
  output$simple <- renderSankeyNetwork({
    sn <- sankeyNetwork(Links = links, Nodes = nodes, 
                        Source = 'source_id', Target = 'target_id', fontSize = 16,
                        colourScale = colorJS,
                        Value = 'value', NodeID = 'label')
    
    
    ###  This next part adds the new data to the widget sn.
    sn$x$nodes <- cbindPad(sn$x$nodes,nodes_cnt)
    
    
    ### This final element adds the value and the percentages to the source and destination node labels.
   
    sn %>%
      htmlwidgets::onRender(jsCode=
      'function() { 
        d3.selectAll(".node").on("mousedown.drag", null); // prevent dragging for click-event
        d3.selectAll(".node").on("click",function(d) { 
            Shiny.onInputChange("clickedNode", {          // get name / count / perc from clicked object d
                Node: d.name,                             // and send clicked node data to shiny using Shiny.onInputChange
                Count: d.cnt,
                Percentage: d.perc
            });
        })
        d3.selectAll("rect").style("cursor", "pointer");  // change cursor style to pointer on rect-objects (nodes)
       }
      ')
  })
  
  # display details of clicked node
  output$node_details <- renderDT({
    req(input$clickedNode)
    
    datatable(
      data.frame(input$clickedNode),
      options = list(
        pageLength = 5,
        searching = FALSE,
        lengthChange = FALSE,
        info = FALSE,
        paging = FALSE
      ),
      rownames = FALSE,
      selection = "none",
      class = "table-bordered table-striped"
    )
    
  })
  
}
shinyApp(ui = ui, server = server)