将 networkD3 中节点上的单击操作链接到选项卡中的内容预览

Question

是否有选项可以使用forceNetwork节点中的clickAction在网格旁边的面板中预览该节点的特定数据？我已经设法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链接到UI中的新面板，该面板将根据单击的节点显示不同的内容！

Answer 1

使用类似clickAction = "Shiny.onInputChange('id', d.description);"的内容将单击的节点的值发送回 Shiny 变量，然后可以在 UI 的反应元素中使用，例如......

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)