admin管理员组文章数量:1356815
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', dt) 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 + " (" + dt + ", " + d.perc + "%)")
}
'
### not sure where to put Shiny.onInputChange('clickedNode', dt) in the above js
### dt 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)
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)
1 Answer
Reset to default 3I 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)
本文标签： rHow to make numbers reactive in Sankey Plot from networkD3Stack Overflow
版权声明：本文标题：r - How to make numbers reactive in Sankey Plot from networkD3 - Stack Overflow 内容由网友自发贡献，该文观点仅代表作者本人， 转载请联系作者并注明出处：http://www.betaflare.com/web/1744071608a2585990.html， 本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌抄袭侵权/违法违规的内容，一经查实，本站将立刻删除。
Error in rename(., value = freq) : unused argument (value = freq)when running your code. Please provide a reproducible example. – Jan Commented Mar 27 at 21:01dplyr::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 though – Tim G Commented Mar 27 at 21:23right_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. – YBS Commented Mar 27 at 21:58right_joinwithcbind. – YBS Commented Mar 27 at 22:38