R plotly + shiny reactive coupled event - Refresh chart with argument from click on same chart

问题

I've been struggling with this all day, so hopefully somebody can explain a working solution for me/point out the error in my approach.

I have this network I want to visualize. The goal is to only show the nodes that are directly connected to the reference node.

I want to update this chart when either 1) the reference node in the drop down list is changed or 2) when I click on one of the outlying nodes in the current plot that should be the new reference node. The first option works, but I can't get 2) to work properly.

In output$selection I have currently commented what I thought should do the job. When I active this however weird looping behaviour happens that I don't understand.

What should I add to get the above described functionality? Below a reproducible example.

library(plotly)
library(shiny)
library(dplyr)
library(tidyr)

### Selectionlist
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)

ui <- fluidPage(
  mainPanel(
    fixedRow(selectInput('selectedID', label = 'Select varid',
                         choices = selectionOptions, 
                         selected = 'VAR1')),

    fixedRow(plotlyOutput("network"))
  ),
  verbatimTextOutput("selection")
)

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

  createGraph <- function(selectedID){
    varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
    derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
    chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
    selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)

    varid_derivedvarid = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'),
                              derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)

    chart_varidderivedvarid = data.frame(chart = c('1.1.1'),
                                   varidderivedvarid = c('OAP1', 'DERIVEDVAR1', 'DERIVEDVAR2', 'DERIVEDVAR3', 'DERIVEDVAR4'),
                                   stringsAsFactors = F)

    # if selectedID is VAR
    if(selectedID %in% varidlist$varid){
      adjacencyMatrix  = varid_derivedvarid %>%
        filter(varid == selectedID) %>%
        mutate(type = 'derivedvarid') %>%
        bind_rows(chart_varidderivedvarid %>%
                    filter(varidderivedvarid == selectedID) %>%
                    rename(varid = varidderivedvarid,
                           derivedvarid = chart) %>%
                    mutate(type='chart')) %>%
        select(derivedvarid, varid, type)

      nodeMatrix = adjacencyMatrix %>%
        select(derivedvarid, type) %>%
        add_row(derivedvarid=selectedID, type='varid')
    }

    # if selectedID is DERIVEDVAR
    if(selectedID %in% derivedvaridlist$derivedvarid){
      adjacencyMatrix  = varid_derivedvarid %>%
        filter(derivedvarid == selectedID) %>%
        mutate(type = 'varid') %>%
        bind_rows(chart_varidderivedvarid %>%
                    filter(varidderivedvarid == selectedID) %>%
                    rename(varid = varidderivedvarid,
                           derivedvarid = chart) %>%
                    mutate(type='chart')) %>%
        select(derivedvarid, varid, type)

      nodeMatrix = adjacencyMatrix %>%
        select(varid, type) %>%
        add_row(varid=selectedID, type='derivedvarid')  
    }

    # if selectedID is chart
    if(selectedID %in% chartlist$charts) {
      adjacencyMatrix  = chart_varidderivedvarid %>%
        filter(chart == selectedID) %>%
        mutate(type = '',
               type = replace(type, varidderivedvarid %in% varidlist$varid, 'varid'),
               type = replace(type, varidderivedvarid %in% derivedvaridlist$derivedvarid, 'derivedvarid')) %>%
        select(varidderivedvarid, chart, type)

      nodeMatrix = adjacencyMatrix %>%
        select(varidderivedvarid, type) %>%
        add_row(varidderivedvarid=selectedID, type='chart') 
    }

    # Create all vertices:
    nrNodes = dim(adjacencyMatrix)[1]
    # Reference node coordinates
    x0 = 0
    y0 = 0
    r = 4

    nodes = data.frame(angles = 2*pi / nrNodes * 1:nrNodes,
                       nodeKey = adjacencyMatrix[, 1]) %>%
      mutate(angles = angles + rnorm(n(), mean = 0, sd = .15), # Add noise to angle to avoid overlap in x-coordinate
             x = x0 + r * cos(angles),
             y = y0 + r * sin(angles)) %>%
      add_row(x=x0, y=y0, nodeKey = selectedID)

    # Create edges
    edges = nodes %>%
      select(x, y, nodeKey) %>%
      filter(nodeKey != selectedID) %>%
      mutate(x0=x0, y0=y0)

    edge_shapes <- list()
    for(i in 1:dim(edges)[1]) {
      edge_shape = list(
        type = "line",
        line = list(color = "#030303", width = 0.3),
        x0 = edges$x0[i],
        y0 = edges$y0[i],
        x1 = edges$x[i],
        y1 = edges$y[i]
      )
      edge_shapes[[i]] <- edge_shape
    }

    # Layout for empty background
    emptyBackground = list(title = "", 
                           showgrid = FALSE, 
                           showticklabels = FALSE, 
                           zeroline = FALSE)

    # Plot plotly
    p = plot_ly(nodes, source='networkplot') %>%
      add_trace(x = ~x, y = ~y, type = 'scatter',
                mode = 'text', text = ~nodeKey, 
                textposition = 'middle',
                hoverinfo='text',
                textfont = list(color = '#000000', size = 16)) %>%
      layout(title='Network',
             showlegend = FALSE,
             shapes = edge_shapes,
             xaxis = emptyBackground,
             yaxis = emptyBackground)

    return(p)
  }  

  output$network <- renderPlotly({
    selectedID = input$selectedID
    createGraph(selectedID)
  })

  output$selection <- renderPrint({
    s <- event_data("plotly_click", source = "networkplot")

    if (length(s) == 0) {
      "Click on a node to use it as reference node"
    } else {
      # Get id of clicked node
      plotdata = plotly_data(createGraph(input$selectedID))
      newvarid = plotdata$nodeKey[s$pointNumber + 1]

      #   updateSelectInput(session,
      #                     inputId = 'selectedID',
      #                     label = 'Select ID',
      #                     choices = selectionOptions,
      #                     selected = newvarid)

      # Get chart coordinates
      cat("You selected: \n\n")
      # as.list(s)
      newvarid
    }
  })
}

shinyApp(ui, server, options = list(display.mode = "showcase"))

回答1:

The trick here is to avoid circular reactive events. When using the updateSelectInput function you commented out, you end up in a loop because the updated input triggers the renderPrint function and renderPrint updates the menu.

You can break this behaviour by introducing observe() functions. One way to do this is to stick the updateSelectInput() function into an observeEvent() function that is only triggered if the user clicks on the plot and not if the dropdown menu is used. Any updates coming from input$selectedID are ignored by this function. Please see the full example below. I indicated the part of the code that changed at the bottom.

library(plotly)
library(shiny)
library(dplyr)
library(tidyr)

### Selectionlist
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)

ui <- fluidPage(
  mainPanel(
    fixedRow(selectInput('selectedID', label = 'Select varid',
                         choices = selectionOptions,
                         selected = 'VAR1')),

    fixedRow(plotlyOutput("network"))
  ),
  verbatimTextOutput("selection")
)

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

  createGraph <- function(selectedID){
    varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
    derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
    chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
    selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)

    varid_derivedvarid = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'),
                                    derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)

    chart_varidderivedvarid = data.frame(chart = c('1.1.1'),
                                         varidderivedvarid = c('OAP1', 'DERIVEDVAR1', 'DERIVEDVAR2', 'DERIVEDVAR3', 'DERIVEDVAR4'),
                                         stringsAsFactors = F)

    # if selectedID is VAR
    if(selectedID %in% varidlist$varid){
      adjacencyMatrix  = varid_derivedvarid %>%
        filter(varid == selectedID) %>%
        mutate(type = 'derivedvarid') %>%
        bind_rows(chart_varidderivedvarid %>%
                    filter(varidderivedvarid == selectedID) %>%
                    rename(varid = varidderivedvarid,
                           derivedvarid = chart) %>%
                    mutate(type='chart')) %>%
        select(derivedvarid, varid, type)

      nodeMatrix = adjacencyMatrix %>%
        select(derivedvarid, type) %>%
        add_row(derivedvarid=selectedID, type='varid')
    }

    # if selectedID is DERIVEDVAR
    if(selectedID %in% derivedvaridlist$derivedvarid){
      adjacencyMatrix  = varid_derivedvarid %>%
        filter(derivedvarid == selectedID) %>%
        mutate(type = 'varid') %>%
        bind_rows(chart_varidderivedvarid %>%
                    filter(varidderivedvarid == selectedID) %>%
                    rename(varid = varidderivedvarid,
                           derivedvarid = chart) %>%
                    mutate(type='chart')) %>%
        select(derivedvarid, varid, type)

      nodeMatrix = adjacencyMatrix %>%
        select(varid, type) %>%
        add_row(varid=selectedID, type='derivedvarid')
    }

    # if selectedID is chart
    if(selectedID %in% chartlist$charts) {
      adjacencyMatrix  = chart_varidderivedvarid %>%
        filter(chart == selectedID) %>%
        mutate(type = '',
               type = replace(type, varidderivedvarid %in% varidlist$varid, 'varid'),
               type = replace(type, varidderivedvarid %in% derivedvaridlist$derivedvarid, 'derivedvarid')) %>%
        select(varidderivedvarid, chart, type)

      nodeMatrix = adjacencyMatrix %>%
        select(varidderivedvarid, type) %>%
        add_row(varidderivedvarid=selectedID, type='chart')
    }

    # Create all vertices:
    nrNodes = dim(adjacencyMatrix)[1]
    # Reference node coordinates
    x0 = 0
    y0 = 0
    r = 4

    nodes = data.frame(angles = 2*pi / nrNodes * 1:nrNodes,
                       nodeKey = adjacencyMatrix[, 1]) %>%
      mutate(angles = angles + rnorm(n(), mean = 0, sd = .15), # Add noise to angle to avoid overlap in x-coordinate
             x = x0 + r * cos(angles),
             y = y0 + r * sin(angles)) %>%
      add_row(x=x0, y=y0, nodeKey = selectedID)

    # Create edges
    edges = nodes %>%
      select(x, y, nodeKey) %>%
      filter(nodeKey != selectedID) %>%
      mutate(x0=x0, y0=y0)

    edge_shapes <- list()
    for(i in 1:dim(edges)[1]) {
      edge_shape = list(
        type = "line",
        line = list(color = "#030303", width = 0.3),
        x0 = edges$x0[i],
        y0 = edges$y0[i],
        x1 = edges$x[i],
        y1 = edges$y[i]
      )
      edge_shapes[[i]] <- edge_shape
    }

    # Layout for empty background
    emptyBackground = list(title = "",
                           showgrid = FALSE,
                           showticklabels = FALSE,
                           zeroline = FALSE)

    # Plot plotly
    p = plot_ly(nodes, source='networkplot') %>%
      add_trace(x = ~x, y = ~y, type = 'scatter',
                mode = 'text', text = ~nodeKey,
                textposition = 'middle',
                hoverinfo='text',
                textfont = list(color = '#000000', size = 16)) %>%
      layout(title='Network',
             showlegend = FALSE,
             shapes = edge_shapes,
             xaxis = emptyBackground,
             yaxis = emptyBackground)

    return(p)
  }

  ###############################################################################################
  ### Updated part
  # Define reactive data
  values <- reactiveValues(newvarid = NULL) # ID = "VAR1"

  # Observer for change in dropdown menu
  # observeEvent(input$selectedID, {
  #   values$ID = input$selectedID
  # })

  # Update dropdown menue based on click event
  observeEvent(event_data("plotly_click", source = "networkplot"), {
    s <- event_data("plotly_click", source = "networkplot")
    plotdata = plotly_data(createGraph(input$selectedID))
    values$newvarid = plotdata$nodeKey[s$pointNumber + 1]
    updateSelectInput(session,
                      inputId = 'selectedID',
                      label = 'Select ID',
                      choices = selectionOptions,
                      selected = values$newvarid)
  })

  # Render Plot
  output$network <- renderPlotly({
    createGraph(input$selectedID)
  })

  # Render text
  output$selection <- renderPrint({
    if (is.null(values$newvarid)) {
      "Click on a node to use it as reference node"
    } else {
      # Get chart coordinates
      cat("You selected: \n\n")
      # as.list(s)
      values$newvarid
    }
  })
}

shinyApp(ui, server, options = list(display.mode = "showcase"))

I am not sure if the reactive values$newvarid is really necessary.

来源：https://stackoverflow.com/questions/42877610/r-plotly-shiny-reactive-coupled-event-refresh-chart-with-argument-from-click