Shiny折线图日期滑块异常：仅显示单个数据点问题排查

问题描述 #

开发的Shiny应用支持用户选择日期范围、荒野区域、物种、生命阶段及站点ID，预期展示各时间点bd值的折线图，但无论选择何种日期范围，仅显示单个数据点（测试数据中无2016年数据，实际为筛选逻辑错误导致匹配数据异常）。

原始代码 #

测试数据 #

bd_data <- structure(list(id = c(10008, 10008,10008), date = c(2018,2019,2020), species = c("ramu", "ramu", "ramu"),
                          wilderness = c("yosemite", "yosemite", "yosemite"), visual_life_stage = c("adult", "adult", "adult"),
                          bd = c(1,2,3)))

UI代码 #

ui <- fluidPage(
  #includeCSS(here("NPS_ShinyApp/theme.css")),
  theme = theme,
  titlePanel(""),
  fluidPage(
    fluidRow(column(8,
                    h1(strong("National Park Service App - RIBBiTR ")))),
  navbarPage("", inverse = T,
             tabPanel("Home", icon = icon("info-circle"),
                      fluidPage(
                        fluidRow(
                          h1(strong("Disclaimer"), style = "font-size:20px;"),
                          column(12, p(""))),
                        fluidRow(
                          h1(strong("Intended Use"),style = "font-size:20px;"),
                          column(12, p(""))),
                        fluidRow(
                          h1(strong("Data Collection"),style = "font-size:20px;"),
                          column(12, p(""))))),
             tabPanel(title = "Site Map", icon = icon("globe-asia"),
                      sidebarLayout(
                        sidebarPanel(
                          sliderInput(inputId = "bd_date",
                                      label = "Select an annual range",
                                      min = min(bd_data$date), max = max(bd_data$date), 
                                      value =  c((max(bd_data$date) - 5), max(bd_data$date)),
                                      sep = ""),
                          pickerInput(inputId = "wilderness_2",
                                      label = "Select a wilderness",
                                      choices = unique(bd_data$wilderness),
                                      multiple = F,
                                      selected = ""),
                          pickerInput(inputId = "bd_species",
                                      label = "Select a species",
                                      choices = unique(bd_data$species),
                                      multiple = F,
                                      selected = "ramu"),
                          pickerInput(inputId = "stage",
                                      label = "Select a life stage",
                                      choices = unique(bd_data$visual_life_stage),
                                      selected = "adult",
                                      multiple = F),
                          pickerInput(inputId = "bd_id",
                                      label = "select site",
                                      choices = unique(bd_data$id),
                                      multiple = F)),
                        mainPanel(plotOutput(outputId = "bd_plots")))
             )
)

Server代码 #

server <- function(input, output, session){
 bd_reac <- reactive({
      bd_data %>% 
        dplyr::filter(date %in% input$bd_date[1:2], wilderness == input$wilderness_2, species == input$bd_species, 
                      visual_life_stage == input$stage, id == input$bd_id)
    })
    output$bd_plots <- renderPlot({
      ggplot(data = bd_reac()) +
        geom_point(aes(x = date, y = bd)) +
        xlim(c(input$bd_date[1:2]))
    })
    observeEvent(input$bd_date, {
      updatePickerInput(session, inputId = "wilderness_2", 
                        choices = unique(bd_data$wilderness[bd_data$date %in% input$bd_date[1:2]]), 
                        selected = "yosemite")
    })
    observeEvent(input$wilderness_2, {
      updatePickerInput(session, inputId = "bd_species", 
                        choices = unique(bd_data$species[bd_data$date %in% input$bd_date[1:2] 
                                                          & bd_data$wilderness == input$wilderness_2]))
    })
    observeEvent(input$bd_species, {
      updatePickerInput(session, inputId = "stage", 
                        choices = unique(bd_data$visual_life_stage[bd_data$date %in% input$bd_date[1:2] 
                                                     & bd_data$wilderness == input$wilderness_2 
                                                     & bd_data$species == input$bd_species]))
    })
    observeEvent(input$stage, {
      updatePickerInput(session, inputId = "bd_id",
                        choices = unique(bd_data$id[bd_data$date %in% input$bd_date[1:2] 
                                                    & bd_data$wilderness == input$wilderness_2 
                                                    & bd_data$species == input$bd_species
                                                    & bd_data$visual_life_stage == input$stage]))
    })
}

Global代码 #

if (!require(librarian)){
  install.packages("librarian")
  library(librarian)
}
librarian::shelf(shiny, tidyverse, here, shinyWidgets, leafem, bslib, thematic, shinymanager, leaflet, ggrepel, sf)

问题根源与修复方案 #

1. 日期筛选逻辑错误 #

原始代码用date %in% input$bd_date[1:2]只能筛选等于滑块起始或结束年份的数据，而非介于两者之间的所有年份。修正为：

date >= input$bd_date[1] & date <= input$bd_date[2]

2. 初始筛选无匹配数据 #

UI中wilderness_2的selected设为空字符串，导致应用启动时无匹配的荒野区域数据，需改为默认选中存在的区域：

pickerInput(inputId = "wilderness_2",
            label = "Select a wilderness",
            choices = unique(bd_data$wilderness),
            multiple = F,
            selected = "yosemite")

3. 折线图未实现 #

原始绘图仅用geom_point显示散点，若要展示折线图需添加geom_line：

ggplot(data = bd_reac()) +
  geom_point(aes(x = date, y = bd), size = 3) +
  geom_line(aes(x = date, y = bd)) +
  xlim(input$bd_date[1], input$bd_date[2])

修正后的核心代码 #

修正后的reactive数据筛选

bd_reac <- reactive({
  bd_data %>% 
    dplyr::filter(date >= input$bd_date[1] & date <= input$bd_date[2], 
                  wilderness == input$wilderness_2, 
                  species == input$bd_species, 
                  visual_life_stage == input$stage, 
                  id == input$bd_id)
})

修正后的绘图代码

output$bd_plots <- renderPlot({
  ggplot(data = bd_reac()) +
    geom_point(aes(x = date, y = bd), size = 3) +
    geom_line(aes(x = date, y = bd)) +
    xlim(input$bd_date[1], input$bd_date[2]) +
    labs(x = "年份", y = "bd值", title = "bd值随年份变化趋势")
})

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