如何在鼠标悬停在闪亮的网络图中捕获节点名称？

Question

对于下面闪亮的应用程序，我想从 MisLinks 数据框中提取所有行，这些行包含直接连接到当前悬停的节点的节点，并将它们显示在侧面板或网络下方。 我试图通过提取当前悬停节点的名称，然后在 MisLinks 数据框中搜索匹配项来解决此问题。但是我无法在鼠标悬停时在 R 变量中捕获节点名称。 请在此链接中查找数据ftp://ftp.lrz.de/transfer/Data/

感谢您的反馈。

#### Load necessary packages
library(shiny)
library(networkD3)

#### Server ####
server <- function(input, output) {
  p <- eventReactive(input$plot_network,
    {
      ## re-write the mouseover and mouseout functions and override them with
      ## htmlwidgets::onRender
    customJS <- '
function(el,x) {
    var link = d3.selectAll(".link")
    var node = d3.selectAll(".node")

    var options = { opacity: 1,
                    clickTextSize: 10,
                    opacityNoHover: 0.1,
                    radiusCalculation: "Math.sqrt(d.nodesize)+6"
                  }

    var unfocusDivisor = 4;

    var links = HTMLWidgets.dataframeToD3(x.links);
    var linkedByIndex = {};

    links.forEach(function(d) {
      linkedByIndex[d.source + "," + d.target] = 1;
      linkedByIndex[d.target + "," + d.source] = 1;
    });

    function neighboring(a, b) {
      return linkedByIndex[a.index + "," + b.index];
    }

    function nodeSize(d) {
            if(options.nodesize){
                    return eval(options.radiusCalculation);
            }else{
                    return 6}
    }

    function mouseover(d) {
      var unfocusDivisor = 4;

      link.transition().duration(200)
        .style("opacity", function(l) { return d != l.source && d != l.target ? +options.opacity / unfocusDivisor : +options.opacity });

      node.transition().duration(200)
        .style("opacity", function(o) { return d.index == o.index || neighboring(d, o) ? +options.opacity : +options.opacity / unfocusDivisor; });

      d3.select(this).select("circle").transition()
        .duration(750)
        .attr("r", function(d){return nodeSize(d)+5;});

      node.select("text").transition()
        .duration(750)
        .attr("x", 13)
        .style("stroke-width", ".5px")
        .style("font", 24 + "px ")
        .style("opacity", function(o) { return d.index == o.index || neighboring(d, o) ? 1 : 0; });
    }

    function mouseout() {
      node.style("opacity", +options.opacity);
      link.style("opacity", +options.opacity);

      d3.select(this).select("circle").transition()
        .duration(750)
        .attr("r", function(d){return nodeSize(d);});
      node.select("text").transition()
        .duration(1250)
        .attr("x", 0)
        .style("font", options.fontSize + "px ")
        .style("opacity", 0);
    }

    d3.selectAll(".node").on("mouseover", mouseover).on("mouseout", mouseout);
}
'
    MisLinks <- as.data.frame(readxl::read_xlsx(input$edge_file$datapath,
                                  col_names = TRUE,
                                  sheet = 1))
    MisNodes <- as.data.frame(readxl::read_xlsx(input$node_file$datapath,
                                                col_names = TRUE,
                                                sheet = 1))
    fn <- forceNetwork(
      Links = MisLinks,
      Nodes = MisNodes,
      Source = "source",
      Target = "target",
      Value = "value",
      NodeID = "name",
      Group = "group",
      linkDistance = 100,
      linkColour = '#999999',
      charge = -50,
      legend = T,
      zoom = T,
      fontSize = 15,
      fontFamily = "sans",
      opacity = 1,
      opacityNoHover = 0
    )
    htmlwidgets::onRender(fn, customJS)
  })

  output$force <- renderForceNetwork({
    p()
  })
}

#### UI ####
ui <- shinyUI(fluidPage(

  titlePanel("Shiny: networkD3"),

  sidebarLayout(
    sidebarPanel(
      ## Upload edge table file in .xlsx format
      fileInput(
        "edge_file",
        "Upload MisLinks.xlsx",
        multiple = FALSE,
        accept = c(".xlsx")
      ),

      ## Upload node attribute table file in .xlsx format
      fileInput(
        "node_file",
        "Upload MisNodes.xlsx",
        multiple = FALSE,
        accept = c(".xlsx")
      ),

      # Display plot
      actionButton("plot_network", "display plot")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Force directed layout", forceNetworkOutput("force"))
      )
    )
  )
))

#### Run ####
shinyApp(ui = ui, server = server)    

Answer 1

我在调用 forceNetwork 函数时添加了 clickAction = MyClickScript 参数。在服务器部分添加的 MyClickScript 函数定义如下，

MyClickScript <- 'Shiny.onInputChange("node_name", d.name);'

然后添加以下 sn-p（在服务器部分）以从边缘表中提取所需的行

data <- reactiveVal(data.frame())

observeEvent(input$node_name,
           {
             idx <-
               union(which(links$source == input$node_name),
                     which(links$target == input$node_name))
             data(links[idx, ])
           })

output$nodeName <- DT::renderDataTable({
DT::datatable(
data(),
rownames = FALSE,
options = list(scrollX  = TRUE,
               searchHighlight = TRUE,
               pageLength = 10,
               search = list(regex = TRUE,
                             caseInsensitive = TRUE))
)
})

另外，在 UI 部分，我在 sidebarPanel 函数中添加了以下行

 DT::dataTableOutput("nodeName")

就是这样！ 尽管它达到了我的目的，但我仍然会寻找更好的解决方案。 我会欣赏一个优雅的解决方案