Связывание clickAction на узле в networkD3 с предварительным просмотром содержимого на вкладке

Question

Есть ли возможность использовать clickAction от forceNetwork узел для предварительного просмотра конкретных данных для этого узла на панели рядом с сеткой? Мне удалось сделать clickAction вызвать гиперссылку, которая ведет на конкретный сайт, но я хотел бы изменить это, чтобы щелчок по узлу просто отображал некоторые данные справа на экране, не выходя из существующего экрана.

Вот код с гиперссылками:

library(shiny)
library(networkD3)

source =c(0,0,1,1,1,
      1,1,2,1,9,
      9,9,8,8,1,
      15,15,2,2,8)

target = c(1,2,3,4,5,
       6,7,8,9,10,
       11,12,13,14,15,
       16,17,18,19,20)

value = c(500,500,500,500,10,
      10,10,10,10,10,
      10,10,10,10,10,
      10,10,10,10,10)
MisLinks = data.frame(source,target,value)


name = c("spellsouls", "product","market", "flow", "progression",
     "guilds", "leaderbords","core mechanic", "audience", "live 
issues",
     "ux", "gd", "art", "personas", "TAM",
     "champions", "art","gd","videos","communication",
     "audience book")
group = c(1,2,2,3,3,
      3,3,3,3,3,
      4,4,4,4,4,
      3,4,4,4,4,
      4)
size = c(300,100,100,5,5,
     5,5,5,3,3,
     3,3,3,5,3,
     3,3,3,3,3,
     3)
hyperlink = c("https://confluence.hq.nordeus.com/x/SqwRAw", 
"http://yahoo.com", "http://google.com", "http://yahoo.com", 
"http://google.com") #can't add more link in preview

MisNodes = data.frame(name, group, size, hyperlink)


ui = fluidPage(theme = "bootstrap.css",
           headerPanel(
             "Game perception: Knowledge base"),
           tabsetPanel(
             tabPanel("insights universe",
                      tags$head(tags$style("#force{height:100vh 
!important;}")),
                      forceNetworkOutput("force")),

             tabPanel("help", 
                      h1("User universe", align = "center"),
                      br(),
                      br(),
                      br(),
                      h4("This is a visual representation of our 
knowledge about Spellsouls", align = "center"),
                      h4("To read into more feedback we got for every 
specific feature of the game,", align = "center"),
                      h4("simply click on any node in the network", 
align = "center")
             )
           )

)





#Myclickaction = "window.open(d.hyperlink, '_blank')"

Myclickaction = "window.alert(d.hyperlink, '_blank')"
server = function(input,output) {

output$force = renderForceNetwork({
fn = forceNetwork(Links = MisLinks, Nodes = MisNodes,
                  Source = "source", Target = "target", charge = 
-150,
                  legend = TRUE, opacityNoHover = 1, Nodesize = 
"size",
                  Value = "value", NodeID = "name", height = 1000, 
fontSize = 12,linkDistance = 50,
                  Group = "group", linkWidth = 2, clickAction = 
Myclickaction,
                  opacity = 0.9, colourScale =  
JS("d3.scaleOrdinal(d3.schemeCategory20);"),
                  zoom=T)
fn$x$nodes$hyperlink <- hyperlink
fn

  })
}
shinyApp(ui = ui, server = server)

Желаемый результат: связать узлы из forceNetwork, к новой панели в пользовательском интерфейсе, которая будет отображать различное содержимое в зависимости от того, на каком узле нажали

Answer 1

Используйте что-то вроде clickAction = "Shiny.onInputChange('id', d.description);" отправить значение выбранного узла обратно в переменную Shiny, которую затем можно использовать в реактивном элементе пользовательского интерфейса, например...

library(shiny)
library(networkD3)

links <- data.frame(source = c(0,0,1,1,1,1,1,2,1,9,9,9,8,8,1,15,15,2,2,8),
                       target = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20),
                       value = c(500,500,500,500,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10))
nodes <- data.frame(name = c("spellsouls", "product","market", "flow", "progression",
                             "guilds", "leaderbords","core mechanic", "audience", 
                             "live issues","ux", "gd", "art", "personas", "TAM",
                             "champions", "art","gd","videos","communication",
                             "audience book"),
                    group = c(1,2,2,3,3,3,3,3,3,3,4,4,4,4,4,3,4,4,4,4,4),
                    size = c(300,100,100,5,5,5,5,5,3,3,3,3,3,5,3,3,3,3,3,3,3))
nodes$description <- paste("This is a description of", nodes$name)


ui = fluidPage(theme = "bootstrap.css",
               headerPanel("Game perception: Knowledge base"),
               tabsetPanel(
                 tabPanel("insights universe",
                          fluidRow(
                            column(10, forceNetworkOutput("force")),
                            column(1, textOutput("text"))
                          )
                        ),
                 tabPanel("help", 
                          h1("User universe", align = "center"),
                          br(),br(),br(),
                          h4("This is a visual representation of our 
                             knowledge about Spellsouls", align = "center"),
                          h4("To read into more feedback we got for every 
                             specific feature of the game,", align = "center"),
                          h4("simply click on any node in the network", 
                             align = "center")
                          )
                        )
               )

server = function(input,output) {
  output$force = renderForceNetwork({
    fn <- forceNetwork(Links = links, Nodes = nodes, Source = "source", 
                      Target = "target", charge = -150, legend = TRUE, 
                      opacityNoHover = 1, Nodesize = "size", Value = "value", 
                      NodeID = "name", height = 1000, fontSize = 12, 
                      linkDistance = 50, Group = "group", linkWidth = 2, 
                      clickAction = "Shiny.onInputChange('id', d.description);",
                      opacity = 0.9, zoom = T)
    fn$x$nodes$description <- nodes$description
    fn
  })

  output$text <- renderPrint({ input$id })
}
shinyApp(ui = ui, server = server)