当应用 JScode 使用 htmlwidgets::onRender() 删除视图框时，通过 renderUI 的 sankeyNetwork 消失

Question

我有一个 Shiny 应用程序，它从 networkD3 包创建一个 sankeyNetwork，它接受输入以更新用于网络的数据，并根据存在的节点数量调整自身大小。我上周发布了并获得了应用反应高度参数所需的帮助。

我之前发现可以解决仅从 Firefox 查看时输出很小的问题。我已经在他们的问题页面上阅读过，这似乎仍然是开放的。

我正在寻求帮助的问题是，当我将这两个解决方案配对时，该应用程序无法按预期运行。在我的实际应用程序中，当我更新其中一个输入时，高度会更新，但用于创建图表的数据是相同的。第二次更新输入后，图表消失并保持消失，直到应用程序终止。

我在这里重新创建了一个玩具示例。这个行为略有不同，因为在接收到更新的输入时，数据和大小都会更新（在我的实际中，只有大小被更新）但消失的行为确实存在。我无法重新创建不更新的数据，但我希望对此进行修复可以解决其他问题。

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)

从链接的问题中删除 htmlwidgets::onRender() 调用允许应用程序按预期执行，数据和大小根据输入进行更新。保留它，两者都会更新，但在第二次切换后，图表消失了。

Answer 1

尝试使用这个...

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

从技术上讲，你根据其文档传递给 htmlwidgets::onRender "must be a valid JavaScript expression that returns a function" 的 JS（尽管 JS 代码以任何一种方式运行，所以你看到了效果），这似乎触发了 "Duplicate binding for ID diagram" 来自 Shiny 的错误，这似乎是导致图消失的原因。您可以用 htmlwidgets::onRender('console.log("test")')

演示相同的 error/problem

我还将其更改为仅获取小部件节点内的元素，这样它更有可能获得正确的 SVG（例如，如果页面上有多个 SVG），我改用了 removeAttribute("viewBox") setAttribute("viewBox", "")，这似乎是一种更直接的方法。

更新 2020.04.02

and/or 使用 querySelector 以避免需要使用 [0] 到 select 列表中的第一个元素（这似乎会引起一堆混乱）.. .

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

也不是上面的语法是可能的，因为 htmlwidget 是 dplyr 链中上一个命令的输出，但通常需要指定 htmlwidgets 对象作为第一个参数，例如...

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") }')

当应用 JScode 使用 htmlwidgets::onRender() 删除视图框时，通过 renderUI 的 sankeyNetwork 消失

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

r

shiny

sankey-diagram

htmlwidgets

networkd3