Search code examples
rshinyshiny-reactivity

Is there a way to prevent observeEvent() from triggering while still entering text in an input box?


I have attempted to make a reproducible example below, although keep in mind that in my app there are many more dependencies.

Basically, I made inputs corresponding to what is in a dataTable. The placeholder for each input is taken directly from the data.
I used lapply() to generate observeEvents for each input boxes, and made it so that if the user changes the value in the inputs, it is sent to the dataset and reflected in the table. This works great and is quite fast!

overview

My problem however, is that if I take my time to write a Petal.Length of 5.33, as soon as I type the number '5', the observeEvent is triggered. If I am quick on the keyboard I can write the number before the event is triggered, but if I take just a 0.1 second too long the event is triggered.

Is there a way for the observeEvent to be triggered only once I have clicked out of the input box? I don't really want to add a 'submit' button at the end of the row, for instance.

Please see my code below:

library(shinyWidgets)
library(dplyr)
library(DT)
library(shinysurveys)

#creating dummy dataset from iris.
dataset <- iris[match(c('setosa','versicolor','virginica'), iris$Species),c(5,1,2,3,4)]
rownames(dataset) <- NULL


# Define UI
ui <- fluidPage(
  
  tags$div(style='box-shadow: 0px 0px 6px rgba(0, 0, 0, 0.25);padding: 28px;width: 500px;margin-bottom: 10px;',
    radioGroupButtons('spSelector','', choices = as.character(dataset$Species), direction = "horizontal", individual = TRUE),
    uiOutput('entryInputs')
  ),
  dataTableOutput('table', width = '500px')
  
)

# Define server logic
server <- function(input, output) {
  
  DataSet <- reactiveVal()
  DataSet(dataset) #storing dataset as a reactiveVal DataSet()
  
  # Below is the renderUI for the input fields
  output$entryInputs <- renderUI({
    species <- input$spSelector
    tagList(
      div(class = 'entryBox',style='display:flex;',
          GetInputBox(species,'Sepal.Length'),
          GetInputBox(species,'Sepal.Width'),
          GetInputBox(species,'Petal.Length'),
          GetInputBox(species,'Petal.Width'),

      )
    )
  })
  
  #function to pull a row from the dataset, depending on which species is selected 
  GetRow <- function(species){
    temp <- DataSet()
    vars<- c('Sepal.Length','Sepal.Width','Petal.Length','Petal.Width')
    grab <- temp[which(temp$Species == species),vars] %>% unlist() %>% as.vector()
    return(grab)
  }
  
  #function to return a numberInput() and assign placeholder if the data cell already has a value.
  # I know, there is probably a cleaner way to do it, but for now it works well. 
  GetInputBox <- function(species,get){
    vars<- c('Sepal.Length','Sepal.Width','Petal.Length','Petal.Width')
    vals <- GetRow(species)
    val = vals[which(vars == get)]
    
    inputList <- list()
    inputList[[1]] <- list(numberInput(paste0('input','Sepal.Length'),label = 'Sepal.Length',placeholder = '---', value = ''),
                           numberInput(paste0('input','Sepal.Length'),label = 'Sepal.Length',placeholder = '---', value = val))
    inputList[[2]] <- list(numberInput(paste0('input','Sepal.Width'),label = 'Sepal.Width',placeholder = '---', value = ''),
                           numberInput(paste0('input','Sepal.Width'),label = 'Sepal.Width',placeholder = '---', value = val))
    inputList[[3]] <- list(numberInput(paste0('input','Petal.Length'),label = 'Petal.Length',placeholder = '---', value = ''),
                           numberInput(paste0('input','Petal.Length'),label = 'Petal.Length',placeholder = '---', value = val))
    inputList[[4]] <- list(numberInput(paste0('input','Petal.Width'),label = 'Petal.Width',placeholder = '---', value = ''),
                           numberInput(paste0('input','Petal.Width'),label = 'Petal.Width',placeholder = '---', value = val))
    
    names(inputList) <- vars
    if(is.na(val)){
      return(inputList[get][[1]][[1]])
    } else {
      return(inputList[get][[1]][[2]])
    }
  }
  
  #making the table
  output$table <- renderDataTable({
    datatable(DataSet(), options = list(dom = 't', autoWidth = TRUE, columnDefs = list(list(width = '50px', targets = "_all"))))
    
  })
  
  #using lapply() to generat the observeEvents and push the inputs to the dataframe/DataSet(). 
  observe({
    vars<- c('Sepal.Length','Sepal.Width','Petal.Length','Petal.Width')
    lapply(1:length(vars), function(i){
      
      observeEvent(input[[paste0('input',vars[i])]],{
        temp <- DataSet()
        temp[which(temp$Species == input$spSelector),vars[i]] <- input[[paste0('input',vars[i])]]
        DataSet(temp)
      })
    })
  })
}

shinyApp(ui, server)

Solution

  • Here is an example on how to use debounce.

    Furthermore I simpified your code (please never nest observers):

    library(DT)
    library(shiny)
    library(dplyr)
    library(datasets)
    library(shinysurveys)
    library(shinyWidgets)
    
    # creating dummy dataset from iris.
    dataset <- iris[match(c('setosa','versicolor','virginica'), iris$Species), c(5,1,2,3,4)]
    rownames(dataset) <- NULL
    colnames(dataset) <- gsub("\\.", "", colnames(dataset)) # avoid period JS special character
    
    numberInputIDs <- setdiff(colnames(dataset), "Species")
    
    # Define UI
    ui <- fluidPage(
      tags$div(style='box-shadow: 0px 0px 6px rgba(0, 0, 0, 0.25);padding: 28px;width: 500px;margin-bottom: 10px;',
               radioGroupButtons('spSelector','', choices = as.character(dataset$Species), direction = "horizontal", individual = TRUE),
               div(class = 'entryBox', style='display:flex;',
                   lapply(numberInputIDs, function(x){numberInput(x, label = x, placeholder = '---', value = dataset[dataset$Species == dataset$Species[1], x], step = 0.1)})
               )
      ),
      DT::dataTableOutput('table', width = '500px')
    )
    
    server <- function(input, output, session) {
      
      rv <- reactiveValues(DataSet = dataset)
      
      observe({
        rv$DataSet[rv$DataSet$Species == isolate(input$spSelector), numberInputIDs] <- setNames(lapply(numberInputIDs, function(x){input[[x]]}), numberInputIDs)
      })
      
      debouncedDataSet <- debounce(r = reactive(rv$DataSet), millis = 1000)
      
      observeEvent(input$spSelector, {
        for(i in seq_along(numberInputIDs)){
          freezeReactiveValue(input, numberInputIDs[i])
          updateNumericInput(
            session = getDefaultReactiveDomain(),
            inputId = numberInputIDs[i],
            value = rv$DataSet[rv$DataSet$Species == input$spSelector, numberInputIDs[i]]
          )
        }
      })
      
      output$table <- DT::renderDataTable({
        datatable(dataset, options = list(dom = 't', autoWidth = TRUE, columnDefs = list(list(width = '50px', targets = "_all"))))
      })
      
      myTableProxy <- dataTableProxy("table")
      
      # faster than re-rendering via renderDataTable
      observe({replaceData(myTableProxy, debouncedDataSet())})
      
    }
    
    shinyApp(ui, server)
    

    result