R Shiny时间序列图表无法渲染，但R脚本运行正常问题求助

问题描述 #

开发基于用户输入生成时间序列图表的Shiny应用时，应用运行无异常，但无法渲染图表。相同逻辑的代码在常规R脚本中可正常生成图表，需排查Shiny中图表不显示的原因。

测试数据 #

mydata<-structure(list(employee = c("Mary", "rob", 
"smary", "rob", "Abe", "Abe"
), joining_date = structure(c(17869, 17862, 17865, 17848, 
17862, 17848), class = "Date"), batch___A_2019 = c(1, 1, 
1, 1, 1, 0), batches___A_2020 = c(0, 0, 0, 0, 0, 1), batch___B_2020 = c(0, 
0, 0, 0, 0, 0), batch___B_2023 = c(0, 0, 0, 0, 0, 0)), row.names = c(NA, 
6L), class = "data.frame")

可正常生成图表的常规R脚本 #

test <- mydata %>%
  mutate(week = week(joining_date)) %>%
  mutate(new_date = format(joining_date, "%m %Y"), year = format(joining_date, "%Y")) %>%
  filter(
    employee == "Mary" | employee == "Abe",
    joining_date >= "2019-01-01" &
      joining_date <= "2023-01-01"
  ) %>%
  group_by(employee,month = lubridate::floor_date(joining_date, 'month')) %>%
  summarize(Total = n(), .groups = "drop") %>%
  complete(month = seq.Date(min(month), max(month), by="month"), employee) %>%
  replace(is.na(.), 0)


g<-ggplot(test, aes(x = month, y = Total)) +
  geom_line(aes(color = employee)) +
  scale_x_date(date_labels = "%b %Y", date_breaks = "1 month") +
  theme(axis.text.x=element_text(angle=50, hjust=1)) +
  ylab("Total joinee") 

无法生成图表的Shiny代码 #

服务器端代码 #

timeseries <- reactive({
    req(input$employee)
    req(input$test)
    req(input$Dates)
    mydata %>%
      filter(
        employee == input$employee,
        if_any(matches(str_c(
          'batch___', tolower(input$test)
        )), ~
          .x == 1),
        joining_date >= input$Dates[1] &
          joining_date <= input$Dates[2]
      ) %>%
      group_by(month = lubridate::floor_date(joining_date, 'month')) %>%
      summarize(Total = n(), .groups = "drop") %>%
      complete(month = seq.Date(min(month), max(month), by="month"), employee) %>%
      replace(is.na(.), 0)
  })
  
  output$timeseriesplot <- renderPlot({
    ggplot(timeseries()) + 
      geom_line(aes(x = month, y = Total, color=input$test)) +
      scale_x_date(date_labels = "%b %Y", date_breaks = "1 month") +
      theme(axis.text.x=element_text(angle=50, hjust=1)) +
      ylab("Total joinee") 
  })

UI代码 #

tabItem(tabName = "Timeseries",
              
              box(
                width = 10,
                
                h2("Time series plot"),
                
                sidebarPanel(
                  selectInput(
                    inputId = "employee",
                    choices = mydata$employee,
                    label = "Search by employee"
                  ),
                  
                  dateRangeInput(
                    "Dates",
                    h5("Select the Dates"),
                    format = "yyyy-mm-dd",
                    start = Sys.Date() - 365
                  ),
                  
                  checkboxGroupInput(
                    inputId = "test",
                    choices = c("A", "B", "C"),
                    selected = c("A", "B", "C"),
                    label = "Select test"
                  )
                ),
                
                mainPanel(plotOutput("timeseriesplot")),
              ),
      ),

问题排查及修正方案 #

1. Reactive数据处理逻辑错误 #

• 缺失employee列导致complete失效：
  常规脚本中按employee和month分组，保留了employee列；但Shiny的reactive仅按month分组，summarize后丢失employee列，后续complete(..., employee)会找不到对应列，导致数据结构异常。需在group_by中加入employee，或在complete中明确指定employee = input$employee。
• 批次匹配逻辑错误：
  str_c('batch___', tolower(input$test))在多选时会生成错误的匹配字符串（如batch___ab），正确写法应为构造正则匹配模式：str_c('batch___', tolower(input$test), collapse = "|")，让matches能匹配所有选中批次的列。
• 初始日期范围过滤所有数据：
  dateRangeInput的初始start为Sys.Date()-365，但测试数据日期均为2019年左右，初始范围会过滤掉所有数据，导致reactive返回空数据框。需调整初始日期范围，或在UI中设置符合测试数据的默认值。
• complete中处理空数据的NA问题：
  当过滤后无数据时，min(month)会返回NA，需添加na.rm = TRUE避免报错。

2. ggplot渲染逻辑错误 #

• color映射错误：
  color=input$test直接使用输入的多选向量，而ggplot的color需要映射数据框中的列。若要按员工区分颜色，应映射employee列；若要按批次区分，需在reactive数据中保留批次分组信息。
• 全局aes设置缺失：
  建议在ggplot()中设置全局aes(x = month, y = Total)，让代码更清晰，也便于排查空数据问题。

修正后的代码示例 #

修正后的Reactive数据处理

timeseries <- reactive({
    req(input$employee)
    req(input$test)
    req(input$Dates)
    
    # 构造正确的批次正则匹配模式
    batch_pattern <- str_c('batch___', tolower(input$test), collapse = "|")
    
    filtered_data <- mydata %>%
      filter(
        employee == input$employee,
        if_any(matches(batch_pattern), ~ .x == 1),
        joining_date >= input$Dates[1] & joining_date <= input$Dates[2]
      )
    
    # 处理过滤后无数据的情况
    if(nrow(filtered_data) == 0){
      return(tibble(month = seq.Date(input$Dates[1], input$Dates[2], by="month"),
                    employee = input$employee,
                    Total = 0))
    }
    
    filtered_data %>%
      group_by(employee, month = lubridate::floor_date(joining_date, 'month')) %>%
      summarize(Total = n(), .groups = "drop") %>%
      complete(month = seq.Date(min(month, na.rm = TRUE), max(month, na.rm = TRUE), by="month"), 
               employee = input$employee,
               fill = list(Total = 0)) %>%
      replace(is.na(.), 0)
  })

修正后的RenderPlot

output$timeseriesplot <- renderPlot({
    ggplot(timeseries(), aes(x = month, y = Total)) + 
      geom_line(aes(color = employee)) +
      scale_x_date(date_labels = "%b %Y", date_breaks = "1 month") +
      theme(axis.text.x=element_text(angle=50, hjust=1)) +
      ylab("Total joinee") +
      labs(color = "Employee")
  })

修正后的UI日期范围

dateRangeInput(
  "Dates",
  h5("Select the Dates"),
  format = "yyyy-mm-dd",
  start = as.Date("2019-01-01"),
  end = as.Date("2023-01-01")
),

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