Блог

Как сделать так, чтобы ‘observeEvent’ НЕ запускался изменениями из ‘updateSelectizeInput’

В этом примере кода таблица данных ‘value $ data’ и таблица данных рендеринга с правой стороны предназначены для имитации базы данных SQL, которая обновляется действием слева.

выбирая разные «автомобили» в selectize1 (автомобили), selectize2 (HP) будет обновляться на основе того, что в настоящее время находится в «базе данных».

Когда пользователь изменяет selectize2 (HP), ‘observeEvent’ обновит «базу данных» новым HP выбранного автомобиля.

Проблема в том, что когда пользователь изменяет выбранный car (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’ и выполнить сравнение внутри observeEvent для ‘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)
 

Нет необходимости сохранять состояние в реактивном значении, вы можете использовать его непосредственно для сравнения. Следовательно, это более прямой подход по сравнению с вашим текущим решением, хотя все еще с инструкцией 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)
  
}