Сделайте два входа зависимыми друг от друга

Question

В моем приложении я могу выбрать названия автомобилей, и этот первый выбор обновляет два дополнительных ввода: категорию автомобиля (A или B) и диапазон mpg. Пока я могу это сделать, но у меня возникают некоторые проблемы, когда я пытаюсь сделать эти два дополнительных входа зависимыми друг от друга. Причина, по которой я хочу сделать их зависимыми друг от друга, состоит в том, что эти два входа не «упорядочены», что означает, что один вход не важнее другого.

В приведенном ниже примере я выбрал 4 машины, некоторые из них относятся к категории A, а другие - к категории B. Когда я выбираю только категорию B, диапазон обновляется так, чтобы он соответствовал автомобилям в выбранной мной категории.

Это работает в этом порядке (изменение первого ввода обновляет диапазон), но я могу ' t выяснить, как сделать эти два входа зависимыми друг от друга. Например, когда я уменьшаю диапазон mpg до 20-21, в таблице остается только категория A, поэтому первый вход должен показывать только A. Добавление другого observeEvent() после определения third_data() делает оба входа пусто.

library(shiny)
library(dplyr)
library(tibble)

mtcars$category <- rep(c("A", "B"), each = 16)
mtcars2 <- mtcars %>%
  rownames_to_column("car_name")

ui <- fluidPage(
  selectInput("car_name", "car name", unique(mtcars2$car_name), 
              multiple = TRUE, selected = c("Mazda RX4", "Dodge Challenger", 
                                            "AMC Javelin", "Camaro Z28")),
  selectInput("category", "category", NULL, multiple = TRUE),
  sliderInput("range_mpg", "range of mpg",
              min = 0,
              max = 0,
              value = c(0, 0)),
  tableOutput("test_table")
)

server <- function(input, output, session) {
  
  first_data <- reactive({
    mtcars2 %>%
      filter(car_name %in% input$car_name)
  })
  
  observeEvent(first_data(), {
    updateSelectInput(
      session = session,
      inputId = "category",
      choices = unique(first_data()$category),
      selected = unique(first_data()$category)
    )
    updateSliderInput(
      session = session,
      inputId = "range_mpg",
      min = min(first_data()$mpg),
      max = max(first_data()$mpg),
      value = c(min(first_data()$mpg), max(first_data()$mpg))
    )
  })
  
  second_data <- reactive({
    first_data() %>%
      filter(category %in% input$category)
  })
  
  observeEvent(second_data(), {
    updateSliderInput(
      session = session,
      inputId = "range_mpg",
      min = min(second_data()$mpg),
      max = max(second_data()$mpg),
      value = c(min(second_data()$mpg), max(second_data()$mpg))
    )
  })
  
  third_data <- reactive({
    second_data() %>%
      filter(between(mpg, input$range_mpg[1], input$range_mpg[2]))
  })
  
  output$test_table <- renderTable({
    third_data()
  })
  
}

shinyApp(ui, server)

Подводя итог, вот ожидаемое поведение:

• когда я выбираю первый вход, диапазон должен быть обновлен, чтобы соответствовать автомобилям в категории, выбранной в первый ввод (DONE).
• когда я меняю диапазон, первый ввод должен быть обновлен, чтобы отображались категории автомобилей, которые находятся в этом диапазоне.

Любая идея о том, как это сделать или о другом «рабочем процессе приложения»?

Answer 1

Возможно, это то, что вы ищете

mtcars$category <- rep(c("A", "B"), each = 16)
mtcars2 <- mtcars %>%
  rownames_to_column("car_name")

ui <- fluidPage(
  selectInput("car_name", "car name", unique(mtcars2$car_name),
              multiple = TRUE, selected = c("Mazda RX4", "Dodge Challenger",
                                            "AMC Javelin", "Camaro Z28")),
  selectInput("category", "category", NULL, multiple = TRUE),
  sliderInput("range_mpg", "range of mpg",
              min = 0,
              max = 0,
              value = c(0, 0)),
  tableOutput("test_table")
)

server <- function(input, output, session) {

  first_data <- eventReactive(input$car_name, {
    mtcars2 %>%
      filter(car_name %in% input$car_name)
  })

  observeEvent(first_data(), {
    updateSelectInput(
      session = session,
      inputId = "category",
      choices = unique(mtcars2$category),
      selected = unique(first_data()$category)
    )
    updateSliderInput(
      session = session,
      inputId = "range_mpg",
      min = min(mtcars2$mpg),
      max = max(mtcars2$mpg),
      value = c(min(first_data()$mpg), max(first_data()$mpg))
    )
  })

  second_data <- eventReactive(input$category, {
    first_data() %>%
      filter(category %in% input$category)
  })

  observeEvent(second_data(), {
    updateSliderInput(
      session = session,
      inputId = "range_mpg",
      min = min(mtcars2$mpg),
      max = max(mtcars2$mpg),
      value = c(min(second_data()$mpg), max(second_data()$mpg))
    )

  })

  third_data <- eventReactive(input$range_mpg, {
    first_data() %>%
      filter(between(mpg, input$range_mpg[1], input$range_mpg[2]))
  })

  output$test_table <- renderTable({
    third_data()
  })
  
  observeEvent(third_data(), {
    updateSelectInput(
      session = session,
      inputId = "category",
      choices = unique(mtcars2$category),
      selected = unique(third_data()$category)
    )
    
  })
  

}

shinyApp(ui, server)