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)



Error in rename(., value = freq) : unused argument (value = freq)when running your code. Please provide a reproducible example.dplyr::rename((2) yourright_joinfails to assign your count / percentages because name and source do not match - this should be fixed first. Then use this to sendShiny.onInputChange("clickedNode", d.name);and observe this on your serverreq(input$clickedNode)withinput$clickedNode. This should get you far. You only need to fix yournodes_cntand print the info using cat likenodes_cnt[nodes_cnt$source == input$clickedNode, ]$cnt. I have 70 % of the answer, not enough to post thoughright_joinfailed for me on the first few tries. Then it started working; not sure why. Actully,nodes$namecontent matchesnodes_cnt$source. However, that is not the same insn$x$nodes.right_joinwithcbind.