observeEvent brush within a reactive event in RShiny

Question

I am showing tabbed graphs for each line that is selected in my initial table. I would like those graphs to have the brush/zoom functionality found here.

Here is my code :

library(shiny)
library(DT)
library(ggplot2)
library(scales)
library(reshape2)

First the ui : the main table with a tabbed UI below that is generated in response to selection of rows in the main table

ui <- fluidPage(
  mainPanel(
    fluidRow(
      column(12,DT::dataTableOutput(outputId = 'tableCurrencies'))
    ),
    fluidRow(
      uiOutput("selectedTabs")
    )
  )
)

Then the server function : the main table values are generated randomly for the sake of the example. The brush functionality is directly lifted from the link provided. I suspect my issue has to do with a reactive function within a reactive function but I'm happy to let the experts decide.

server <- function(input,output){

  output$tableCurrencies <- DT::renderDataTable({datatable(data.frame(a=rnorm(10),b=rnorm(10),c=rnorm(10)))})

  origTable_selected <- reactive({
    ids <- input$tableCurrencies_rows_selected
    return(ids)
  })

  rangeRates <- reactiveValues(xRate = NULL, yRate = NULL)

  output$selectedTabs <- renderUI({
    myTabs <- lapply(origTable_selected(),function(i) {


      tabName <- paste0("test",i)

      a <- renderPlot({
        hist(rnorm(50))
      })
      output[[paste0(tabName,"rates")]] <- a
      #plot of realized vol and implied vols over 5 years

      observeEvent(input[[paste0(tabName,"rates_dblclick")]], {
        brush <- input[[paste0(tabName,"rates_brush")]]
        if (!is.null(brush)) {
          rangeRates$xRate <- c(brush$xmin, brush$xmax)
          rangeRates$yRate <- c(brush$ymin, brush$ymax)

        } else {
          rangeRates$xRate <- NULL
          rangeRates$yRate <- NULL
        }
      })

      return(tabPanel(
        tabName,
        fluidRow(
          column(6,plotOutput(paste0(tabName,"rates")))
        )
      ))
    })
    return(do.call(tabsetPanel,myTabs))
  })
}
app = shinyApp(ui,server)
runApp(app,port=3250,host='0.0.0.0')

Answer 1

You need to assign the "doubleclick id" and the "brush id" in the plotOutput call

column(6, plotOutput(paste0(tabName, "rates"),
                     dblclick = paste0(tabName, "rates_dblclick"),
                     brush = brushOpts(
                       id = paste0(tabName, "rates_brush"),
                       resetOnNew = TRUE
                    )))

Now the observers trigger properly and send the right information. There is still a second issue with rangeRates not having any effect on the plots which can be solved the following way

a <- renderPlot({
  if (!is.null(rangeRates$xRate))
    hist(rnorm(50), xlim = rangeRates$xRate,
         ylim = rangeRates$yRate)
  else
    hist(rnorm(50))
})

Here is the full working version

library(shiny)
library(DT)

ui <- fluidPage(
  mainPanel(
    fluidRow(column(12, DT::dataTableOutput(outputId = 'tableCurrencies'))),
    fluidRow(uiOutput("selectedTabs"))
  )
)

server <- function(input, output){      
  output$tableCurrencies <- DT::renderDataTable({
    data.frame(a = rnorm(10), b = rnorm(10), c = rnorm(10))
  })

  origTable_selected <- reactive({
    ids <- input$tableCurrencies_rows_selected
    return(ids)
  })

  rangeRates <- reactiveValues(xRate = NULL, yRate = NULL)

  output$selectedTabs <- renderUI({
    myTabs <- lapply(
      origTable_selected(), 
      function(i) {       
        tabName <- paste0("test", i)

        output[[paste0(tabName, "rates")]] <- renderPlot({
          if( !is.null(rangeRates$xRate) )
            hist(rnorm(50), xlim = rangeRates$xRate,
                 ylim = rangeRates$yRate)
          else
            hist(rnorm(50))
        })

        observeEvent(input[[paste0(tabName, "rates_dblclick")]], {
          brush <- input[[paste0(tabName, "rates_brush")]]
          if (!is.null(brush)) {
            rangeRates$xRate <- c(brush$xmin, brush$xmax)
            rangeRates$yRate <- c(brush$ymin, brush$ymax)              
          } else {
            rangeRates$xRate <- NULL
            rangeRates$yRate <- NULL
          }
        })

        tabPanel(
          tabName,
          fluidRow(column(6, plotOutput(
            paste0(tabName, "rates"),
            dblclick = paste0(tabName, "rates_dblclick"),
            brush = brushOpts(
              id = paste0(tabName, "rates_brush"),
              resetOnNew = TRUE)
          )))
        )
      })
    return(do.call(tabsetPanel, myTabs))
  })
}

shinyApp(ui, server)