r - 为 networkD3 应用程序实现工具提示

我想在 Shiny 托管的 networkD3 图中实现一个类似于 ggvis 函数的工具提示，例如:

require(ggvis); require(shiny)
all_values = function(x){ "<a href='#'>Option 1</a><br/><a href='#'>Option 2</a>"}

server = function(input, output, session) {
  observe({
    ggvis(mtcars, ~disp, ~mpg) %>% layer_points() %>%
      add_tooltip(all_values, 'click') %>%
      bind_shiny('ggvis_plot', 'ggvis_ui')
  })
}

ui = fluidPage( uiOutput("ggvis_ui"), ggvisOutput("ggvis_plot"))
shinyApp(ui, server)

对于简单的 networkD3 绘图，是否有一种优雅的 Shiny 或 D3/javascript 方式来实现这一点 - 如下所示？

library(shiny); library(networkD3)

server <- function(input, output) {
  output$simple <- renderSimpleNetwork({
    src <- c("A", "A", "A", "A", "B", "B", "C", "C", "D")
    target <- c("B", "C", "D", "J", "E", "F", "G", "H", "I")
    networkData <- data.frame(src, target)
    simpleNetwork(networkData)
  })
}

ui <- shinyUI(fluidPage(simpleNetworkOutput("simple")))
shinyApp(ui = ui, server = server)

最佳答案

您几乎肯定需要使用 forceNetwork ，因为它有一个 clickAction 参数，可以让您添加 JavaScript。这是一个非常粗略的例子......

clickJS <- "
d3.selectAll('.xtooltip').remove();
d3.select('body').append('div')
  .attr('class', 'xtooltip')
  .style('position', 'absolute')
  .style('border', '1px solid #999')
  .style('border-radius', '3px')
  .style('padding', '5px')
  .style('opacity', '0.85')
  .style('background-color', '#fff')
  .style('box-shadow', '2px 2px 6px #888888')
  .html('name: ' + d.name + '<br>' + 'group: ' + d.group)
  .style('left', (d3.event.pageX) + 'px')
  .style('top', (d3.event.pageY - 28) + 'px');
"

library(shiny)
library(networkD3)

server <- function(input, output) {
  output$simple <- renderSimpleNetwork({
    src <- c("A", "A", "A", "A", "B", "B", "C", "C", "D")
    target <- c("B", "C", "D", "J", "E", "F", "G", "H", "I")

    node_names <- factor(sort(unique(c(as.character(src),
                                       as.character(target)))))
    nodes <- data.frame(name = node_names, group = 1, size = 8)
    links <- data.frame(source = match(src, node_names) - 1,
                        target = match(target, node_names) - 1,
                        value = 1)

    forceNetwork(Links = links, Nodes = nodes, Source = "source",
                 Target = "target", Value = "value", NodeID = "name",
                 Group = "group", clickAction = clickJS)
  })
}

ui <- shinyUI(fluidPage(simpleNetworkOutput("simple")))
shinyApp(ui = ui, server = server)

关于r - 为 networkD3 应用程序实现工具提示，我们在Stack Overflow上找到一个类似的问题：https://stackoverflow.com/questions/44110370/