Dynamic Modules and Plotly::event_data not working

shiny
1

Good afternoon!

Using dynamic module creation, and Plotly event_data, I'm not able to get the event selection/click to work in the correct module. I've used the second code's dynamic module system before without any issues. When I create the modules manually, everything works perfectly. But, because I will need to create an unknown number of modules in the final app, it will need to remain dynamic.

Working Example -

library(shiny)
library(tidyverse)
library(plotly)

reusableUI <- function(id = NULL) {
  ns <- NS(id)
  
  fluidPage(
    selectInput(inputId = ns("xaxis"), label = "X Axis", names(mtcars)),
    selectInput(inputId = ns("yaxis"), label = "y Axis", names(mtcars)),
    actionButton('browser', 'browser'),
    plotlyOutput(ns("p")),
    verbatimTextOutput(ns("ev"))
  )
  
}

reusableScatter <- function(input, output, session, source, eventClick, eventSelect) {

  rv <- reactiveValues(
    id = NA
  )
  
  output$p <- renderPlotly({
    
    p <- mtcars %>% rownames_to_column("name") %>%
      mutate(out = ifelse(name %in% rv$id,T,F)) %>% 
      ggplot(aes_string(x = input$xaxis, y = input$yaxis, key = "name", color = "out")) +
      geom_point()
    
     p %>% ggplotly(source = source) %>% 
       layout(dragmode = "lasso")

  })
  
  eventClick_d <- reactive(eventClick()) %>% debounce(500)
  
  observeEvent(eventClick_d(), {
    d <- eventClick()
    if (is_empty(d)){return()}
    if (!is.null(d) || is_empty(d)) {
      rv$id <- c(rv$id, d %>% pull(key)) %>% unique()
    }
  }, ignoreInit = T)
  
  observeEvent(eventSelect(), {
    d <- eventSelect()

    if (is_empty(d)){return()}

    if (!is.null(d)) {
      rv$id <- c(rv$id, d %>% pull(key)) %>% unique()
    }
  }, ignoreInit = T)
  
  output$ev <- renderPrint({
    rv$id
  })
  
}

ui <- fluidPage(
  actionButton("go", "go"),
  reusableUI("AA"),
  reusableUI("BB")
)

server <- function(input, output, session) {
  
  event_select <- reactiveValues()
  event_click <- reactiveValues()
  
  observeEvent(input$go,{
    event_click[["AA"]] <-   reactive(event_data("plotly_click", source = "AA"))
    event_click[["BB"]] <-   reactive(event_data("plotly_click", source = "BB"))
  
    event_select[["AA"]] <-   reactive(event_data("plotly_selected", source = "AA"))
    event_select[["BB"]] <-   reactive(event_data("plotly_selected", source = "BB"))
  
  
    callModule(
      reusableScatter, "AA", session = session, source = "AA", eventClick = event_click[["AA"]], eventSelect = event_select[["AA"]]
    )
    
    callModule(
      reusableScatter, "BB", session = session, source = "BB", eventClick = event_click[["BB"]], eventSelect = event_select[["BB"]]
    )
  }, ignoreInit = T)
  
}

shinyApp(ui, server)

When I create the modules dynamically I'm not able to get the modulized event_data() selection/click to work properly. When I select a data point from the "AA" graph it should only color on the "AA" graph. Unfortunately, it is working on both graphs.
Not Working Example --

 library(shiny)
  library(tidyverse)
  library(plotly)
  
  mdl <- c("AA", "BB")
  
  reusableUI <- function(id = NULL) {
    ns <- NS(id)
    
    fluidPage(
      selectInput(inputId = ns("xaxis"), label = "X Axis", names(mtcars)),
      selectInput(inputId = ns("yaxis"), label = "y Axis", names(mtcars)),
      plotlyOutput(ns("p")),
      verbatimTextOutput(ns("ev"))
    )
    
  }
  
  reusableScatter <- function(input, output, session, source, eventClick, eventSelect) {
    
    rv <- reactiveValues(
      id = NA
    )
    
    output$p <- renderPlotly({
      
      p <- mtcars %>% rownames_to_column("name") %>%
        mutate(out = ifelse(name %in% rv$id,T,F)) %>% 
        ggplot(aes_string(x = input$xaxis, y = input$yaxis, key = "name", color = "out")) +
        geom_point()
      
      p %>% ggplotly(source = source) %>% 
        layout(dragmode = "lasso")
      
    })
    
    eventClick_d <- reactive(eventClick()) %>% debounce(500)
    
    observeEvent(eventClick_d(), {
      d <- eventClick()
      if (is_empty(d)){return()}
      if (!is.null(d) || is_empty(d)) {
        rv$id <- c(rv$id, d %>% pull(key)) %>% unique()
      }
    }, ignoreInit = T)
    
    observeEvent(eventSelect(), {
      d <- eventSelect()
      
      if (is_empty(d)){return()}
      
      if (!is.null(d)) {
        rv$id <- c(rv$id, d %>% pull(key)) %>% unique()
      }
    }, ignoreInit = T)
    
    output$ev <- renderPrint({
      rv$id
    })
    
  }
  
  ui <- fluidPage(
    actionButton('go', 'go'),
    reusableUI("AA"),
    reusableUI("BB")
  )
  
  server <- function(input, output, session) {
    
    event_select <- reactiveValues()
    event_click <- reactiveValues()
    modules <- reactiveValues()
    
    observeEvent(input$go,{
      
      for (i in 1:2){
        
        MDL <- mdl[i]
        
        modules[[MDL]] <<- callModule(
          module = reusableScatter, 
          id = MDL, 
          session = session, 
          source = MDL, 
          eventClick = event_click[[MDL]], eventSelect = event_select[[MDL]]
        )
        
        event_click[[MDL]] <<-  reactive(event_data("plotly_click", source = MDL))
        event_select[[MDL]] <<- reactive(event_data("plotly_selected", source = MDL))
        
      }
  
    },ignoreInit = T)
    
    
  }
  
  shinyApp(ui, server)

Thanks in advance!

2

I've taken the liberty of refactoring and simplifying a little bit as I was going through the code, and when I finished the refactoring, the code worked without having to debug anything.

library(shiny)
library(tidyverse)
library(plotly)

modules <- c("AA", "BB")

reusableUI <- function(id = NULL) {
  ns <- NS(id)
  
  tagList(
    selectInput(inputId = ns("xaxis"), label = "X Axis", names(mtcars)),
    selectInput(inputId = ns("yaxis"), label = "y Axis", names(mtcars)),
    plotlyOutput(ns("plot")),
    verbatimTextOutput(ns("events"))
  )
  
}

reusableScatter <- function(input, output, session, source) {
  
  ids <- reactiveVal(NULL)
  
  output$plot <- renderPlotly({
    
    p <- mtcars %>% rownames_to_column("name") %>%
      mutate(out = ifelse(name %in% ids(), TRUE, FALSE)) %>% 
      ggplot(aes_string(x = input$xaxis, y = input$yaxis, key = "name", color = "out")) +
      geom_point()
    
    p %>% ggplotly(source = source) %>% 
      layout(dragmode = "lasso")
    
  })

  eventClick <- reactive(event_data("plotly_click", source = source)) %>% debounce(500)

  observeEvent(eventClick(), {
    evt <- eventClick()
    if (is_empty(evt)) {
      return()
    }
    if (!is.null(evt) || is_empty(evt)) {
      new_ids <- c(ids(), evt %>% pull(key)) %>% unique()
      ids(new_ids) 
    }
  }, ignoreInit = TRUE)
  
  output$events <- renderPrint({
    ids()
  })
  
  return(eventClick)
}

ui <- fluidPage(
  actionButton("aa","aa"),
  actionButton("go", "go"),
  reusableUI("AA"),
  reusableUI("BB")
)

server <- function(input, output, session) {
  
  event_click <- reactiveValues()
  
  observeEvent(input$go, {
    lapply(modules, function(mdl) {
      event_click[[mdl]] <<- callModule(reusableScatter, mdl, source = mdl)
    })
  })
}

shinyApp(ui, server)
1 Like
3

Awesome. @daattali that works great.

It seems like moving the event_data outside of the module fixed the issue.

Thanks!

4

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.