sankeyNetwork through renderUI disappears when applying JScode to remove viewbox with htmlwidgets::onRender()

Question

I have a Shiny app that creates a sankeyNetwork from the networkD3 package which accepts inputs to update the data used for the network and also resizes itself based on the number of nodes present. I posted a question last week and got the help I needed to get the reactive height argument applied.

I had previously found this question to resolve an issue where the output was tiny when viewed only from Firefox. I've read around on their issue pages and this still seems to be open.

My problem I'm seeking help for is that when I pair these two solutions, the app doesn't work as expected. In my actual app, when I update one of the inputs the height updates but the data used to create the diagram is the same. After updating the input a second time, the diagram disappears and remains gone until the app is terminated.

I have recreated a toy example here. This one behaves slightly different in that upon receiving updated inputs the data and size are both updated (in my actual one only the size is updated) but the disappearing act is indeed present. I couldn't recreate the data not updating but I'm hopeful that a fix for that will fix the other issue.

library(shiny)
library(dplyr)
library(networkD3)

ui <- fluidPage(
  selectInput(inputId = "plot",
              label   = "plot",
              choices = c("plota", "plotb")),

  uiOutput("diagram_dynamic")
)

server <- function(input, output) {

  dat <- data.frame(plot   = c("plota", "plota", "plotb", "plotb", "plotb"),
                    start  = c("a", "b", "a", "b", "c"),
                    finish = c("x", "x", "y", "y", "z"),
                    count  = c(12, 4, 5, 80, 10))

  temp_dat <- reactive({
    filter(dat, plot == input$plot)
  })

  links <- reactive({
    temp_dat <- temp_dat()
    data.frame(source = temp_dat$start,
               target = temp_dat$finish,
               value  = temp_dat$count)
  })

  nodes <- reactive({
    temp_links_1 <- links()
    data.frame(name = c(as.character(temp_links_1$source),
                        as.character(temp_links_1$target))#,
    ) %>%
      unique()
  })

  links2 <- reactive({
    temp_links <- links()
    temp_nodes <- nodes()
    temp_links$IDsource <- match(temp_links$source, temp_nodes$name) - 1
    temp_links$IDtarget <- match(temp_links$target, temp_nodes$name) - 1
    temp_links
  })

  output$diagram <- renderSankeyNetwork({
    sankeyNetwork(
      Links       = links2(),
      Nodes       = nodes(),
      Source      = "IDsource",
      Target      = "IDtarget",
      Value       = "value",
      NodeID      = "name",
      sinksRight  = FALSE,
      fontSize    = 13
    ) %>%
      htmlwidgets::onRender('document.getElementsByTagName("svg")[0].setAttribute("viewBox", "")')  
      # commenting out the above line (and the pipe above that) allows the app to work as expected
  })

  output$diagram_dynamic <- renderUI({
      height_val <- as.character(100*nrow(nodes()))
      sankeyNetworkOutput("diagram", height = height_val)
  })

}

shinyApp(ui = ui, server = server)

Removing the htmlwidgets::onRender() call from the linked question allows the app to perform as expected, with the data and size updating based on the inputs. Leave it in and both will update but after switching a second time the diagram disappears.

CJ Yetman · Accepted Answer · 2020-04-02T08:42:12.643

Try using this...

htmlwidgets::onRender('function(el) { el.getElementsByTagName("svg")[0].removeAttribute("viewBox") }')

Technically, the JS you pass to htmlwidgets::onRender "must be a valid JavaScript expression that returns a function" according to its documentation (though the JS code runs either way, so you see the effect), and that seems to trigger the "Duplicate binding for ID diagram" error from Shiny which seems to be what causes the disappearing plots. You can demonstrate the same error/problem with htmlwidgets::onRender('console.log("test")')

I also changed it to only get elements within the widget’s node so that it's more likely to get the proper SVG (e.g. if you have more than one SVG on the page), and I used removeAttribute("viewBox") instead of setAttribute("viewBox", ""), which seems a bit more direct of an approach.

UPDATE 2020.04.02

and/or use querySelector to avoid needing to use [0] to select the first element in the list (which seems to cause a bunch of confusion)...

htmlwidgets::onRender('function(el) { el.querySelector("svg").removeAttribute("viewBox") }')

also not that the above syntax is possible because the htmlwidget is the output of the previous command in the dplyr chain, but usually one would need to specify the htmlwidgets object as the first argument, for instance...

sn <- sankeyNetwork(Links = links, Nodes = nodes, Source = "source", 
                Target = "target", Value = "value", NodeID = "name", 
                NodeGroup = "group", fontSize = 12, sinksRight = FALSE)

htmlwidgets::onRender(sn, 'function(el) { el.querySelector("svg").removeAttribute("viewBox") }')

sankeyNetwork through renderUI disappears when applying JScode to remove viewbox with htmlwidgets::onRender()

1 Answers1

Linked