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

Question

我想在 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)

是否有一种优雅的 Shiny 或 D3/javascript 方法可以为简单的 networkD3 图实现这一点 - 如下所示？

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)

Answer 1

您几乎肯定需要使用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)

Answer 2

这也可以通过networkD3::simpleNetwork使用来实现htmlwidgets::onRender

library(shiny)
library(networkD3)
library(htmlwidgets)

clickJS <- "
function(el) {
  d3.select(el)
    .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')
  ;

  d3.select(el)
    .selectAll('.node')
    .on('click', function(d) { 
      d3.select(el)
        .select('.xtooltip')
        .html('name: ' + d.name + '<br>' + 'group: ' + d.group)
        .style('left', (d3.event.pageX) + 'px')
        .style('top', (d3.event.pageY - 28) + 'px')
      ;
    })
}
"

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)
    sn <- simpleNetwork(networkData)
    onRender(sn, clickJS)
  })
}

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