Dynamically name x-node of networkD3 sankey

Question

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?

Answer 1

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)