如何调整Shiny代码实现仅日期范围含周五时展示均值表格

问题根源 #

你的原有逻辑和预期需求不匹配：原有代码是判断测试数据集的date1/date2是否落在选择的日期区间内，而非判断选择的区间本身是否包含周五，因此出现两个不符合预期的情况：

• 选择11月2日-11月5日时，测试数据集的date1（全为11月1日）、date2（10月22日、10月29日）均不在所选区间内，过滤后数据为空，因此无结果输出
• 选择11月1日-11月2日时，11月1日落在date1范围内，因此即使区间内没有周五，仍然会输出均值表

调整方案 #

修改data_subset的判断逻辑：先检查用户选择的日期区间内是否包含周五，仅当包含周五时返回提前计算好的周五均值表，否则不返回任何内容。
这里使用as.POSIXlt(days)$wday == 5判断周五（POSIXlt的wday属性中0代表周日，5代表周五，避免系统语言差异导致的星期文字匹配失败问题）。

修改后完整代码 #

library(shiny)
library(shinythemes)
library(dplyr)

Test <- structure(list(date1 = as.Date(c("2021-11-01","2021-11-01","2021-11-01","2021-11-01")),
                       date2 = as.Date(c("2021-10-22","2021-10-22","2021-10-29","2021-10-29")), 
                       Week = c("Friday", "Friday", "Friday", "Friday"),
                       Category = c("FDE", "ABC", "FDE", "ABC"), 
                       time = c(4, 6, 6, 3)), class = "data.frame",row.names = c(NA, -4L))
# 提前计算固定的周五均值
meanTest <- Test %>%
  group_by(Week,Category) %>%
  summarize(`mean(time)` = mean(time), .groups = "drop")

ui <- fluidPage(
  shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                    br(),
                    tabPanel("",
                             sidebarLayout(
                               sidebarPanel(
                                 uiOutput('daterange')
                               ),
                               mainPanel(
                                 dataTableOutput('table')
                               )
                             ))
  ))

server <- function(input, output,session) {
  
  data <- reactive(Test)
  
  output$daterange <- renderUI({
    dateRangeInput("daterange1", "Period you want to see:",
                   min   = min(data()$date1))
  })
  
  data_subset <- reactive({
    req(input$daterange1)
    req(input$daterange1[1] <= input$daterange1[2])
    # 生成所选区间的所有日期
    days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
    # 判断区间内是否有周五（wday=5对应周五）
    has_friday <- any(as.POSIXlt(days)$wday == 5)
    # 仅当有周五时返回均值表
    req(has_friday)
    meanTest
  })
  
  output$table <- renderDataTable({
    data_subset()
  })
  
}

shinyApp(ui = ui, server = server)

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