I am trying to have produce a shiny application in which a Sankey plot, produced using NetworkD3, dynamically produces x-node labels. I think this requires passing a reactive element to onRender, but I am not sure how to do this.
I see an answer here: How to add columnn titles in a Sankey chart networkD3, but this solves the dynamic naming by calling .text("Step " (i 1)); in the onRender function. My labels are not so generic that I can just iterate and paste (the example below uses simplified names).
Here is an example:
library('shiny')
library('tidyverse')
library('networkD3')
library(shinyWidgets)
library(htmlwidgets)
#Create the data
df <- data.frame('A' = c('a', 'b', 'b', 'c', 'a'),
'B' = c('1', '1', '1', '2', '3'),
'C' = c('red', 'blue', 'blue', 'green', 'green'))
#Create the UI
ui <- fluidPage(
#Sidebar to select x-nodes
sidebarLayout(
sidebarPanel(
pickerInput(inputId = 'var_select',
label = 'Variables',
choices = colnames(df),
selected = colnames(df),
multiple = TRUE,
pickerOptions(actionsBox = TRUE))
),
#Mainpanel to show sankey plot
mainPanel(
sankeyNetworkOutput('plot',
height = '800px')
)
)
)
#Create the server
server <- function(input, session, output) {
#create a reactive function that outputs the selected variables
df_sankey <- reactive({
df %>%
select(input$var_select)
})
#Prepare for plotting in NetworkD3
links1 <- reactive({
df_sankey() %>%
mutate(row = row_number()) %>% # add a row id
pivot_longer(-row, names_to = "col", values_to = "source") %>% # gather all columns
mutate(col = match(col, names(df_sankey()))) %>% # convert col names to col ids
mutate(source = paste0(source, '_', col)) %>% # add col id to node names
group_by(row) %>%
mutate(target = lead(source, order_by = col)) %>% # get target from following node in row
ungroup() %>%
filter(!is.na(target)) %>% # remove links from last column in original data
group_by(source, target) %>%
summarise(value = n(), .groups = "drop") # aggregate and count similar links
})
#Now create the nodes
nodes <- reactive({
data.frame(id = unique(c(links1()$source, links1()$target)),
stringsAsFactors = F) %>%
mutate(name = sub('_[0-9]*$', '', id))
})
#Mutate a soutrce id variable - have to create this as links2 to prevent endless recursion
links2 <- reactive({
mutate(links1(), source_id = match(links1()$source, nodes()$id) - 1)
})
#Do the same for target id
links <- reactive({
mutate(links2(), target_id = match(links2()$target, nodes()$id) - 1) %>%
data.frame()
})
#Build the sankey plot
plot1 <- reactive({
sankeyNetwork(Links = links(), Nodes = nodes(),
Source = 'source_id', Target = 'target_id', Value = 'value', NodeID = 'name',
fontSize = 14)
})
#Here is the problematic code
#under code starting var labels - i need that to be produced by a reactive element: colnames(df_sankey())
#Without this it just take the number of var labels as there are selected variables
output$plot <- renderSankeyNetwork({
onRender(plot1(), '
function(el) {
var cols_x = this.sankey.nodes().map(d => d.x).filter((v, i, a) => a.indexOf(v) === i).sort(function(a, b){return a - b});
var labels = ["A", "B", "C"];
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
')
})
}
#call the application
shinyApp(ui, server)
I call out the problem in the comments above the onRender function. Effectively I need var labels to take a reactive function generated by something like: colnames(df_sankey()). If i put that code in for var labels (which i appreciate is a wild guess), it just fails. Without the reactive function the code just loops through the var labels according to the number of variables selected. You can see the problem if you select var A and C - C gets labelled B. I also tried (another guess):
output$plot <- renderSankeyNetwork({
onRender(plot1(), '
function(el, node_labels) {
var cols_x = this.sankey.nodes().map(d => d.x).filter((v, i, a) => a.indexOf(v) === i).sort(function(a, b){return a - b});
var labels = [node_labels];
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
', node_labels = colnames(df_sankey()))
But that also fails. I can't seem to find an explanation for how to pass reactive functions to onRender.
How can I pass a reactive function to the onRender function so that i can dynamically name my x-nodes?
CodePudding user response：
The jsCode argument of htmlwidgets::onRender() is simply a character vector that happens to contain valid JavaScript code, so you can build/modify that just as you can any other string in R. If you want to set the array values of the var labels = ["A", "B", "C"]; line of the JavaScript dynamically, you could do something like this...
col_labels <- c("A", "B", "C")
col_lables_js_arrray_string <- paste0('["', paste(col_labels, collapse = '", "'), '"]')
render_js <- paste('
function(el) {
var cols_x = this.sankey.nodes()
.map(d => d.x)
.filter((v, i, a) => a.indexOf(v) === i)
.sort(function(a, b){return a - b});
var labels = ', col_lables_js_arrray_string, ';
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
')
htmlwidgets::onRender(x = p, jsCode = render_js)
CodePudding user response：
Full working code for the above example posted below:
library('shiny')
library('tidyverse')
library('networkD3')
library('shinyWidgets')
library('htmlwidgets')
#Create the data
df <- data.frame('A' = c('a', 'b', 'b', 'c', 'a'),
'B' = c('1', '1', '1', '2', '3'),
'C' = c('red', 'blue', 'blue', 'green', 'green'))
#Create the UI
ui <- fluidPage(
#Sidebar to select x-nodes
sidebarLayout(
sidebarPanel(
pickerInput(inputId = 'var_select',
label = 'Variables',
choices = colnames(df),
selected = colnames(df),
multiple = TRUE,
pickerOptions(actionsBox = TRUE))
),
#Mainpanel to show sankey plot
mainPanel(
sankeyNetworkOutput('plot',
height = '800px')
)
)
)
#Create the server
server <- function(input, session, output) {
#create a reactive function that outputs the selected variables
df_sankey <- reactive({
df %>%
select(input$var_select)
})
#create a reactive function for the array that will populate the var labels
col_lables_js_arrray_string <- reactive({
paste0('["', paste(colnames(df_sankey()), collapse = '", "'), '"]')
})
#Prepare for plotting in NetworkD3
links1 <- reactive({
df_sankey() %>%
mutate(row = row_number()) %>% # add a row id
pivot_longer(-row, names_to = "col", values_to = "source") %>% # gather all columns
mutate(col = match(col, names(df_sankey()))) %>% # convert col names to col ids
mutate(source = paste0(source, '_', col)) %>% # add col id to node names
group_by(row) %>%
mutate(target = lead(source, order_by = col)) %>% # get target from following node in row
ungroup() %>%
filter(!is.na(target)) %>% # remove links from last column in original data
group_by(source, target) %>%
summarise(value = n(), .groups = "drop") # aggregate and count similar links
})
#Now create the nodes
nodes <- reactive({
data.frame(id = unique(c(links1()$source, links1()$target)),
stringsAsFactors = F) %>%
mutate(name = sub('_[0-9]*$', '', id))
})
#Mutate a soutrce id variable - have to create this as links2 to prevent endless recursion
links2 <- reactive({
mutate(links1(), source_id = match(links1()$source, nodes()$id) - 1)
})
#Do the same for target id
links <- reactive({
mutate(links2(), target_id = match(links2()$target, nodes()$id) - 1) %>%
data.frame()
})
#Build the sankey plot
plot1 <- reactive({
sankeyNetwork(Links = links(), Nodes = nodes(),
Source = 'source_id', Target = 'target_id', Value = 'value', NodeID = 'name',
fontSize = 14)
})
#paste the array for the var labels into the string that will run as valid js code
render_js <- reactive({
paste('function(el) {
var cols_x = this.sankey.nodes().map(d => d.x).filter((v, i, a) => a.indexOf(v) === i).sort(function(a, b){return a - b});
var labels = ',col_lables_js_arrray_string(),';
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}')
})
#render the sankey network, by calling the reactive js code string
output$plot <- renderSankeyNetwork({
onRender(plot1(), jsCode = render_js())
})
}
#call the application
shinyApp(ui, server)