爲networkD3應用實施提示

Question

我想要實現的閃亮託管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) 

有一種優雅的光澤或D3/JavaScript的方式爲了實現這個簡單的網絡D3圖 - 如下？

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)