0

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)

output

5
  • I get Error in rename(., value = freq) : unused argument (value = freq) when running your code. Please provide a reproducible example. Commented Mar 27 at 21:01
  • @Jan yes, (1) you need to add dplyr::rename( (2) your right_join fails to assign your count / percentages because name and source do not match - this should be fixed first. Then use this to send Shiny.onInputChange("clickedNode", d.name); and observe this on your server req(input$clickedNode) with input$clickedNode. This should get you far. You only need to fix your nodes_cnt and print the info using cat like nodes_cnt[nodes_cnt$source == input$clickedNode, ]$cnt. I have 70 % of the answer, not enough to post though Commented Mar 27 at 21:23
  • Thanks @Tim G. right_join failed for me on the first few tries. Then it started working; not sure why. Actully, nodes$name content matches nodes_cnt$source. However, that is not the same in sn$x$nodes. Commented Mar 27 at 21:58
  • Sorry, I can't reproduce your plot using the code you provided. Commented Mar 27 at 22:31
  • 1
    Please try the updated code. I have replaced right_join with cbind. Commented Mar 27 at 22:38

1 Answer 1

3

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.

out

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")

out

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)
Sign up to request clarification or add additional context in comments.

2 Comments

@Tim G, Thank you for the answer. It is very much appreciated. I had one more request to get the dynamic labels. For now, I am using var labels = ["Baseline","Week2","Week4","Week6"]; in js to get the labels on top. It would be best to pick unique visits from df for labels.
@YBS you can give your df over to javaScript to using jsCode= paste0('let uniqueVisits = ' jsonlite::toJSON(unique(df$visits))) and then use it in Javascript to find your labels or (2) look at the output of d: place a console.log(d) and look at the output in the browser tools. You will see that each node d has a lot of information attached, maybe this will help you match your labels to it and send it over to observe

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.