Обновите таблицу данных после нажатия на сетевой узел в блестящем приложении

Question

У меня есть простое блестящее приложение, которое отображает сеть, и в таблице ниже вы можете видеть все соединения между узлами через ребра и имена ребер.Я хотел бы обновить datatable, чтобы показывать только информацию о выбранном узле при щелчке по узлу.Например, когда Iclick на узле "articaine", в таблице будут отображаться только соединения "articaine".

#dataset
id<-c("articaine","benzocaine","etho","esli")
  label<-c("articaine","benzocaine","etho","esli")
  node<-data.frame(id,label)

  from<-c("articaine","articaine","articaine","articaine","articaine","articaine","articaine","articaine","articaine")
  to<-c("benzocaine","etho","esli","benzocaine","etho","esli","benzocaine","etho","esli")
  title<-c("SCN1A","SCN1A","SCN1A","SCN2A","SCN2A","SCN2A","SCN3A","SCN3A","SCN3A")

  edge<-data.frame(from,to,title)

#app

#ui.r
library(igraph)
library(visNetwork)
library(dplyr)
library(shiny)
library(shinythemes)
library(DT)

ui <- fluidPage(theme = shinytheme("cerulean"),  # Specify that the Cerulean Shiny theme/template should be used

                # Generate Title Panel at the top of the app
                titlePanel("Network Visualization App"),  

                # Render as a sidebarLayout. Shiny expects that a sidebarPanel() function and a mainPanel() function are present.

                sidebarLayout(

                  # Sidebar section. Can set the width of the sidebar for any value ranging from 1 to 12.

                  sidebarPanel(             
                  ), # End of the sidebar panel code

                  # Define the main panel
                  mainPanel(

                    h3("Network Visualization"),

                    # Plot the network diagram within the main panel. 
                    # Note that visNetworkOutput is not a Shiny package function, but a visNetwork package function.
                    visNetworkOutput("plot2"),
                    fluidRow(
                      DTOutput('tbl')
                    )

                    ) # End of main panel code

                )
)
#server.r
library(igraph)
library(visNetwork)
library(dplyr)
library(shiny)
library(shinythemes)

server <- function (input, output, session){


  # Use the renderVisNetwork() function to render the network data.

  output$plot2 <- renderVisNetwork({
    visNetwork(nodes = node,edge)%>% 


      visOptions(highlightNearest=T, nodesIdSelection = T) %>%

      # Specify that hover interaction and on-screen button navigations are active
      visInteraction(hover = T, navigationButtons = T) %>%

      visIgraphLayout()

  })
  output$tbl = renderDT(
    edge, options = list(lengthChange = FALSE)
  )
}

Answer 1

Вот альтернативное решение, которое позволяет выбрать несколько узлов и не использует observe, но в остальном оно похоже на опубликованное решение firmo23.Я фильтрую любые ребра с выбранными узлами в столбце «до» или «из», поскольку мне было неясно, о чем вы просили.

Кроме того, некоторые комментарии к макету: боковая панель и главная панельмакет не требуется.Я предпочитаю вложения fluidRow() и column() для явного определения панелей, что я и сделал ниже.

library(igraph)
library(visNetwork)
library(dplyr)
library(shiny)
library(shinythemes)
library(DT)

#dataset
id<-c("articaine","benzocaine","etho","esli")
label<-c("articaine","benzocaine","etho","esli")
node<-data.frame(id,label)

from<-c("articaine","articaine","articaine",
        "articaine","articaine","articaine",
        "articaine","articaine","articaine")
to<-c("benzocaine","etho","esli","benzocaine","etho","esli","benzocaine","etho","esli")
title<-c("SCN1A","SCN1A","SCN1A","SCN2A","SCN2A","SCN2A","SCN3A","SCN3A","SCN3A")

edge<-data.frame(from,to,title)


#app

ui <- fluidPage(

  # Generate Title Panel at the top of the app
  titlePanel("Network Visualization App"),

  fluidRow(
    column(width = 6,
           DTOutput('tbl')),
    column(width = 6,
           visNetworkOutput("network")) #note that column widths in a fluidRow should sum to 12
  ),
  fluidRow(column(width = 6), 
           column(width=6, "Click and hold nodes for a second to select additional nodes.")
  )

) #end of fluidPage


server <- function (input, output, session){

  output$network <- renderVisNetwork({
    visNetwork(nodes = node,edge) %>% 
      visOptions(highlightNearest=TRUE, 
                 nodesIdSelection = TRUE) %>%
      #allow for long click to select additional nodes
      visInteraction(multiselect = TRUE) %>%
      visIgraphLayout() %>% 

      #Use visEvents to turn set input$current_node_selection to list of selected nodes
      visEvents(select = "function(nodes) {
                Shiny.onInputChange('current_node_selection', nodes.nodes);
                ;}")

  })

  #render data table restricted to selected nodes
  output$tbl <- renderDT(
    edge %>% 
      filter((to %in% input$current_node_selection)|(from %in% input$current_node_selection)),
    options = list(lengthChange = FALSE)
  )

}

shinyApp(ui, server)

^{Создано в 2018-09-24 Представить пакет (v0.2.1)}

Answer 2

Я заставил это работать как:

#ui.r
    library(igraph)
    library(visNetwork)
    library(dplyr)
    library(shiny)
    library(shinythemes)
    library(DT)

    ui <- fluidPage(theme = shinytheme("cerulean"),  # Specify that the Cerulean Shiny theme/template should be used

                    # Generate Title Panel at the top of the app
                    titlePanel("Network Visualization App"),  

                    # Render as a sidebarLayout. Shiny expects that a sidebarPanel() function and a mainPanel() function are present.

                    sidebarLayout(

                      # Sidebar section. Can set the width of the sidebar for any value ranging from 1 to 12.

                      sidebarPanel(             
                      ), # End of the sidebar panel code

                      # Define the main panel
                      mainPanel(

                        h3("Network Visualization"),

                        # Plot the network diagram within the main panel. 
                        # Note that visNetworkOutput is not a Shiny package function, but a visNetwork package function.
                        visNetworkOutput("plot2"),

                          dataTableOutput("nodes_data_from_shiny"),
                          uiOutput('dt_UI')


                        ) # End of main panel code

                    )
    )
    #server.r
    library(igraph)
    library(visNetwork)
    library(dplyr)
    library(shiny)
    library(shinythemes)

    server <- function (input, output, session){


      # Use the renderVisNetwork() function to render the network data.

      output$plot2 <- renderVisNetwork({

        visNetwork(nodes,edge)%>% 
          visEvents(select = "function(nodes) {
                    Shiny.onInputChange('current_node_id', nodes.nodes);
                    ;}")%>%

          visOptions(highlightNearest=T, nodesIdSelection = T) %>%

          # Specify that hover interaction and on-screen button navigations are active
          visInteraction(hover = T, navigationButtons = T) %>%

          visIgraphLayout()

      })

      myNode <- reactiveValues(selected = '')

      observeEvent(input$current_node_id, {
        myNode$selected <<- input$current_node_id
      })
      output$table <- renderDataTable({
        edge[which(myNode$selected == edge$from),]
      })
      output$dt_UI <- renderUI({
        if(nrow(edge[which(myNode$selected == edge$from),])!=0){
          dataTableOutput('table')
        } else{}

      })
    }