闪亮的Visnetwork互动和事件

Question

I'm trying to create the effect of an interactive legend for a network visualization. Ideally, I'd like the user to be able to click a legend node and it would highlight/focus in the larger network chart.

I have a similar network chart I've been able to use a selectInput drop-down to do the highlight/focus action using something like the snippet below, but I don't know how to pass the values from another network vs a selectInput.

 observe({
    visNetworkProxy("vis_1") %>%
      visFocus(id = input$Focus, scale = 1)%>%
      visSelectNodes(id = input$Focus)
    #  visSetSelection(id = input$Focus, highlightEdges = TRUE)
  })

My thought is to create two network charts (one small one to serve as the legend) and a larger, overall network. I could then click the legend and zero in on the group in larger chart. Below is sample data to create the first part (legend chart and network chart)... I'm not sure how to pass the click event and the corresponding group.

library(shiny)
library(visNetwork)
library(DT)

server <- function(input, output, session) {
  ## data
  nodes <- data.frame(id = 1:3, 
                      name = c("first", "second", "third"), 
                      group = c("info1", "info1", "info2"),
                      color = c("blue","blue","red"))
  edges <- data.frame(from = c(1,2), to = c(2,2), id = 1:2)

  ## data for legend network  
  nodesb <- data.frame(id = c("info1","info2"),
                       color = c("blue","red"))


  ##  network
  output$network_proxy1 <- renderVisNetwork({
    visNetwork(nodes, edges, main = "Network Chart") %>%
    visEvents(select = "function(nodes) {
                Shiny.onInputChange('current_node_id', nodes.nodes);
                ;}")
    })
  ## legend network
  output$network_proxy2 <- renderVisNetwork({
    visNetwork(nodesb, main = "Legend") %>%
    visEvents(select = "function(nodes) {
                Shiny.onInputChange('current_node_id', nodes.nodes);
                ;}")
    })



}

ui <- fluidPage(
  visNetworkOutput("network_proxy2", height = "100px"),
  visNetworkOutput("network_proxy1", height = "400px")
)

shinyApp(ui = ui, server = server)

Answer 1

You almost had it. You can reference Shiny.onInputChange values in your server function, treating it as any other input. Here is how that will look:

library(shiny)
library(visNetwork)
library(DT)
library(dplyr)

server <- function(input, output, session) {
  ## data
  nodes <- data.frame(id = 1:3, 
                      name = c("first", "second", "third"), 
                      group = c("info1", "info1", "info2"),
                      color = c("blue","blue","red"))
  edges <- data.frame(from = c(1,2), to = c(2,2), id = 1:2)

  ## data for legend network  
  nodesb <- data.frame(id = c("info1","info2"),
                       color = c("blue","red"))


  ##  network
  output$network_proxy1 <- renderVisNetwork({
    visNetwork(nodes, edges, main = "Network Chart")
})
  ## legend network
  output$network_proxy2 <- renderVisNetwork({
    visNetwork(nodesb, main = "Legend") %>%
      visEvents(select = "function(nodes) {
                Shiny.onInputChange('current_node_id_legend', nodes.nodes);
                ;}")
})

  # Find the ID of the gorup selected and focus on the first element
  observe({

    id = nodes%>%
      filter(group %in% input$current_node_id_legend)%>%
      .$id%>%
      .[1]

    visNetworkProxy("network_proxy1") %>%
      visFocus(id = id, scale = 4)
  })

}

ui <- fluidPage(
  visNetworkOutput("network_proxy2", height = "100px"),
  visNetworkOutput("network_proxy1", height = "400px")
)

shinyApp(ui = ui, server = server)