2

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)
3
  • 3
    I think you need debounce.
    – r2evans
    Jan 25 at 6:03
  • @r2evans I have been fiddling with debounce() with no luck.. my observers are automatically generated and I cannot seem to be able to wrap them with debounce.
    – Adrarc
    Jan 25 at 7:41
  • @Adrarc below please find an example. Jan 25 at 11:49

1 Answer 1

2

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

4
  • I can follow what your code is doing by reading it, thank you very much for this. However it's hard for me to properly grasp as when trying to run it, it doesn't work on my side. I made sure that the datatables were rendered from the correct package, but the table does not render. I also get Warning: Error in <-: replacement has length zero [No stack trace available]
    – Adrarc
    Jan 25 at 13:08
  • @Adrarc I just checked - seems to be working fine. I added a gif. Can you please try again - maybe with updated libraries? Jan 25 at 13:24
  • 1
    @Adrarc btw. are you aware of the fact, that you could do the editing directly in the datatable? Also see this PR. Jan 25 at 14:21
  • 1
    thanks, the library(datasets) did it. Yes, I knew that! I am making a simple app to be accessed on tablets, and simple data input is more user-friendly with bigger css-modified input boxes (instead of directly in the datatable). Thank you very much for your help on this.
    – Adrarc
    Jan 25 at 14:40

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.