在 R 闪亮中，如何使“observeEvent”不会被“updateSelectizeInput”的更改触发

Posted 2023-02-24

【中文标题】在 R 闪亮中，如何使“observeEvent”不会被“updateSelectizeInput”的更改触发

【英文标题】：In R shiny, how to make 'observeEvent' NOT get triggered by changes from 'updateSelectizeInput'

【发布时间】：2021-03-04 08:28:30

【问题描述】：

如何使“observeEvent”不会被“updateSelectizeInput”的更改触发

在此示例代码中，右侧的数据表“value$data”和“render data table”模拟了一个通过左侧操作更新的 SQL 数据库。

通过在 selectize1(cars) 上选择不同的“汽车”，selectize2(HP) 将根据“数据库”上的当前内容进行更新。

当用户更改 selectize2(HP) 时，'observeEvent' 将使用所选汽车的新 HP 更新 'database'。

问题是：当用户改变选择的汽车（selectize1）时，updateSelectizeInput会导致'observeEvent'不必要的触发和数据库不必要的更新。

关于如何避免这个问题的任何建议？

library(shiny)
library(tibble)
library(dplyr)
library(shinyjs)
value <- reactiveValues()
dt <- mtcars %>% 
  rownames_to_column(var = 'cars') %>% 
  slice_head(n = 5) %>% 
  select(cars, mpg, hp)
value$data <- dt


ui <- fluidPage(    
  titlePanel("Example App"),
  sidebarLayout(      
    sidebarPanel(
      shinyjs::useShinyjs(),
      div(style="display: inline-block;",
        selectizeInput("cars", "Cars:", 
                    choices=dt$cars,width = 200)
      ),
      div(style="display: inline-block;",
        selectizeInput(
          'hp',"hp:",
          choices = unique(dt$hp),
          width = 200)
      ),
      helpText("You can change cars hp info here"),
      div(id='actions','actions:')
    ),
    mainPanel(
      dataTableOutput("datatable1")
    )
    
  )
)

# Define the server code
server <- function(session,input, output) 
  observeEvent(input$cars,
    updateSelectizeInput(session,'hp',selected = value$data$hp[value$data$cars==input$cars])
  )
  
  observeEvent(input$hp,
    value$data$hp[value$data$cars==input$cars] <- input$hp
    shinyjs::html(
      id = 'actions',
      add = TRUE,
      html = paste0('<br> updated dt table at ', input$cars, 'on ', Sys.time())
    )
  )
    output$datatable1 <- renderDataTable(value$data)
    

 
# Return a Shiny app object
shinyApp(ui = ui, server = server)

我当前的解决方案是将值保存在“updateSelectizeInput”之前的反应值中，并在“hp”的观察事件中进行比较。 希望有更好的方法来做到这一点。

library(shiny)
library(tibble)
library(dplyr)
library(shinyjs)
value <- reactiveValues()
dt <- mtcars %>% 
  rownames_to_column(var = 'cars') %>% 
  slice_head(n = 5) %>% 
  select(cars, mpg, hp)
value$data <- dt

saveValue <- reactiveValues()
saveValue$value <- ''


ui <- fluidPage(    
  titlePanel("Example App"),
  sidebarLayout(      
    sidebarPanel(
      shinyjs::useShinyjs(),
      div(style="display: inline-block;",
          selectizeInput("cars", "Cars:", 
                         choices=dt$cars,width = 200)
      ),
      div(style="display: inline-block;",
          selectizeInput(
            'hp',"hp:",
            choices = unique(dt$hp),
            width = 200)
      ),
      helpText("You can change cars hp info here"),
      div(id='actions','actions:')
    ),
    mainPanel(
      dataTableOutput("datatable1")
    )
    
  )
)

# Define the server code
server <- function(session,input, output) 
  observeEvent(input$cars,
    saveValue$value <- value$data$hp[value$data$cars==input$cars]
    updateSelectizeInput(session,'hp',selected = value$data$hp[value$data$cars==input$cars])
  )
  
  observeEvent(input$hp,ignoreInit = TRUE,
    if(saveValue$value!=input$hp)
      value$data$hp[value$data$cars==input$cars] <- input$hp
      shinyjs::html(
        id = 'actions',
        add = TRUE,
        html = paste0('<br> updated dt table at ', input$cars, 'on ', Sys.time())
      )
    
  )
  output$datatable1 <- renderDataTable(value$data)
  


# Return a Shiny app object
shinyApp(ui = ui, server = server)

【问题讨论】：

也许您可以添加一个actionButton() 来启动对数据库的写入？

反应性的行为方式应该是，你需要像在你身边那样用额外的代码来控制它

【参考方案1】：

不需要将状态保存在响应式值中，您可以直接使用它进行比较。因此，与您当前的解决方案相比，这是一种更直接的方法，尽管仍然使用 if 语句（如果您正在寻找没有的解决方案，请发表评论）。

这里有没有使用saveValue的服务器代码

server <- function(session,input, output) 
  observeEvent(input$cars,
    updateSelectizeInput(session,'hp',selected = value$data$hp[value$data$cars==input$cars])
  )
  
  observeEvent(input$hp,ignoreInit = TRUE,
    checkValue <- value$data$hp[value$data$cars==input$cars]
    if(checkValue != input$hp)
      value$data$hp[value$data$cars==input$cars] <- input$hp
      shinyjs::html(
        id = 'actions',
        add = TRUE,
        html = paste0('<br> updated dt table at ', input$cars, 'on ', Sys.time())
      )
    
  )
  output$datatable1 <- renderDataTable(value$data)