Как захватить имя узла при наведении мыши на блестящий график сети?

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

Я добавил clickAction = MyClickScript параметр при вызове функции forceNetwork. Функция MyClickScript, которая добавляется в серверную часть, определяется следующим образом:

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

Затем добавлен следующий фрагмент (в серверной части) для извлечения нужных строк из таблицы ребер

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))
)
})

Кроме того, в части пользовательского интерфейса я добавил следующую строку внутри функции sidebarPanel

 DT::dataTableOutput("nodeName")

Вот и все! Хотя это и послужило моей цели, я все равно искал бы лучшее решение. Я буду признателен за элегантное решение