有没有办法在仍然在输入框中输入文本的同时防止触发 observeEvent()？

Question

我试图在下面制作一个可重现的示例，但请记住，在我的应用程序中有更多的依赖项。

基本上，我输入的内容与数据表中的内容相对应。每个输入的占位符直接取自数据。
我使用 lapply() 为每个输入框生成 observeEvents，这样如果用户更改输入中的值，它就会被发送到数据集并反映在 table 中。这很好用而且速度很快！

但是我的问题是，如果我花时间写一个 5.33 的 Petal.Length，只要我输入数字“5”，就会触发 observeEvent。如果我在键盘上的速度很快，我可以在事件触发之前输入数字，但如果我只用了 0.1 秒太长，事件就会被触发。

有没有办法让observeEvent只在我点击输入框外时触发？例如，我真的不想在行尾添加 'submit' 按钮。

请看下面我的代码：

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)

Answer 1

这里有一个如何使用 debounce 的例子。

此外，我简化了您的代码（请不要嵌套观察者）：

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)

有没有办法在仍然在输入框中输入文本的同时防止触发 observeEvent()？

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

r

shiny

shiny-reactivity