R Shiny滑块区间过滤失效及联动功能问题求助

问题说明 #

• 原race_distance_furlongs下拉框无法选择带0.5增量的数值（如16.5、17.5），改用sliderInput后数据过滤逻辑异常
• 需要实现Race ID选择时联动更新Horse下拉选项，支持多选/取消选择

用户原始代码 #

ui <- fluidPage(
  titlePanel("Race Dashboard"),
  sidebarLayout(
    sidebarPanel(
      pickerInput("race_ID", "Race ID", order(sort(unique(NH_shiny$race_ID))), options = list(`actions-box` = TRUE)),
      sliderInput("race_distance_furlongs", "Distance",min = distance_range[1], max = distance_range[2],value = distance_range,step = 0.5),
      pickerInput("going", "Going", multiple = TRUE, choices = sort(unique(NH_shiny$going)), options = list(`actions-box` = TRUE)),
      pickerInput("racecourse", "Racecourse", multiple = TRUE, sort(unique(NH_shiny$racecourse)), options = list(`actions-box` = TRUE)),
      pickerInput("horse", "Horse", multiple = TRUE, choices = sort(unique(NH_shiny$horse)), options = list(`actions-box` = TRUE)),
      pickerInput("race_class", "Class", multiple = TRUE, choices = sort(unique(NH_shiny$race_class)), options = list(`actions-box` = TRUE)),
      pickerInput("hurdle_or_chase", "Race type", multiple = TRUE, choices = sort(unique(NH_shiny$hurdle_or_chase)), options = list(`actions-box` = TRUE))
    ),
    mainPanel(
      tableOutput("raceTable")
    )
  )
)

server <- function(input, output) {
    output$raceTable <- renderTable({
      filtered_data <- NH_shiny
    
      if (!is.null(input$race_ID)) {
      filtered_data <- filtered_data[filtered_data$race_ID %in% input$race_ID, ]
      
      # Update the horse filter based on the selected race_ID
      updateSelectInput(inputId = "horse", choices = unique(filtered_data$horse))
    }
    
    if (!is.null(input$going)) {
      filtered_data <- filtered_data[filtered_data$going %in% input$going, ]
    }
    
    if (!is.null(input$racecourse)) {
      filtered_data <- filtered_data[filtered_data$racecourse %in% input$racecourse, ]
    }
    
    if (!is.null(input$horse)) {
      filtered_data <- filtered_data[filtered_data$horse %in% input$horse, ]
    }
    
    if (!is.null(input$race_class)) {
      filtered_data <- filtered_data[filtered_data$race_class %in% input$race_class, ]
    }
    
    if (!is.null(input$hurdle_or_chase)) {
      filtered_data <- filtered_data[filtered_data$hurdle_or_chase %in% input$hurdle_or_chase, ]
    }
   
    if (!is.null(input$race_distance_furlongs)) {
      filtered_data <- filtered_data[filtered_data$race_distance_furlongs %in% input$race_distance_furlongs, ]
    }
      filtered_data <- filter(filtered_data,race_distance_furlongs >= input$race_distance_furlongs[1] & race_distance_furlongs <= input$race_distance_furlongs[2])
  })
    
}

shinyApp(ui = ui, server = server)

问题分析与修复方案 #

1. 距离过滤逻辑错误 #

原始代码中同时使用%in%匹配和范围过滤，input$race_distance_furlongs是长度为2的向量（滑块的最小值和最大值），用%in%会只保留距离等于这两个值的行，和后续范围过滤冲突，需删除错误的%in%判断代码。

2. Horse联动更新错误 #

• 使用updateSelectInput无法更新pickerInput，需替换为updatePickerInput
• 联动逻辑放在renderTable中会导致重复触发，改用observeEvent监听race_ID变化，独立处理更新

3. 过滤条件空值判断错误 #

pickerInput未选择时返回character(0)而非NULL，用!is.null判断会导致未选择时错误过滤数据，需改为判断输入长度是否大于0

修复后代码 #

library(shiny)
library(shinyWidgets)
library(dplyr)

ui <- fluidPage(
  titlePanel("Race Dashboard"),
  sidebarLayout(
    sidebarPanel(
      pickerInput("race_ID", "Race ID", choices = order(sort(unique(NH_shiny$race_ID))), 
                  options = list(`actions-box` = TRUE)),
      sliderInput("race_distance_furlongs", "Distance",
                  min = distance_range[1], max = distance_range[2],
                  value = distance_range, step = 0.5),
      pickerInput("going", "Going", multiple = TRUE, 
                  choices = sort(unique(NH_shiny$going)), 
                  options = list(`actions-box` = TRUE)),
      pickerInput("racecourse", "Racecourse", multiple = TRUE, 
                  choices = sort(unique(NH_shiny$racecourse)), 
                  options = list(`actions-box` = TRUE)),
      pickerInput("horse", "Horse", multiple = TRUE, 
                  choices = sort(unique(NH_shiny$horse)), 
                  options = list(`actions-box` = TRUE)),
      pickerInput("race_class", "Class", multiple = TRUE, 
                  choices = sort(unique(NH_shiny$race_class)), 
                  options = list(`actions-box` = TRUE)),
      pickerInput("hurdle_or_chase", "Race type", multiple = TRUE, 
                  choices = sort(unique(NH_shiny$hurdle_or_chase)), 
                  options = list(`actions-box` = TRUE))
    ),
    mainPanel(
      tableOutput("raceTable")
    )
  )
)

server <- function(input, output, session) {
  # 监听Race ID变化，联动更新Horse选项
  observeEvent(input$race_ID, {
    if (length(input$race_ID) > 0) {
      filtered_horses <- NH_shiny %>% 
        filter(race_ID %in% input$race_ID) %>% 
        pull(horse) %>% 
        unique() %>% 
        sort()
      updatePickerInput(session, inputId = "horse", choices = filtered_horses)
    } else {
      # 未选择Race ID时恢复所有马匹选项
      updatePickerInput(session, inputId = "horse", choices = sort(unique(NH_shiny$horse)))
    }
  })
  
  output$raceTable <- renderTable({
    filtered_data <- NH_shiny
    
    # 过滤Race ID
    if (length(input$race_ID) > 0) {
      filtered_data <- filtered_data %>% filter(race_ID %in% input$race_ID)
    }
    
    # 过滤场地状况
    if (length(input$going) > 0) {
      filtered_data <- filtered_data %>% filter(going %in% input$going)
    }
    
    # 过滤赛道
    if (length(input$racecourse) > 0) {
      filtered_data <- filtered_data %>% filter(racecourse %in% input$racecourse)
    }
    
    # 过滤马匹
    if (length(input$horse) > 0) {
      filtered_data <- filtered_data %>% filter(horse %in% input$horse)
    }
    
    # 过滤赛事等级
    if (length(input$race_class) > 0) {
      filtered_data <- filtered_data %>% filter(race_class %in% input$race_class)
    }
    
    # 过滤赛事类型
    if (length(input$hurdle_or_chase) > 0) {
      filtered_data <- filtered_data %>% filter(hurdle_or_chase %in% input$hurdle_or_chase)
    }
    
    # 过滤距离范围
    filtered_data <- filtered_data %>% 
      filter(race_distance_furlongs >= input$race_distance_furlongs[1],
             race_distance_furlongs <= input$race_distance_furlongs[2])
    
    filtered_data
  })
}

shinyApp(ui = ui, server = server)

内容的提问来源于stack exchange，提问作者Ryan Walter