R Shiny仅含时分秒数据的sliderInput滑块显示时间范围异常问题

• 时分秒列转换失败：原代码中对admissionList.simpleCheckHour列的类型转换使用了比较运算符<，而非赋值运算符<-，导致该列始终为字符型，前置的6:30-9:00筛选规则完全失效，凌晨时段的无效数据被纳入滑块范围计算，最终显示的时间范围不符合预期。
• 滑块时间格式未配置：shiny的sliderInput对时间类型默认展示完整的年月日+时间信息，未配置格式参数的情况下会出现多余的年份字段。
• 存在未定义对象调用：服务端BD96函数中调用了不存在的BD91()对象，会直接触发运行错误。

1. 修正时分秒列的赋值语句，确保成功转换为hms格式
2. 为sliderInput添加timeFormat = "%H:%M:%S"参数，指定仅展示时分秒，隐藏日期信息
3. 修正未定义对象调用问题，替换为正确的数据源
4. 若需要固定6:30-9:00的滑动范围，可直接指定固定的min/max值，避免动态取值偏差

library(shiny)
library(tidyverse)
library(DT)
library(lubridate)

# 构造测试数据
surgeon.lastname<-as.factor(c("pedro","pedro","juan","andres",
                              "camilo","juan","andres","camilo","andres",
                              "claudia",NA,"juan","juan","juan","claudia",
                              "camilo"))
specialty.name<-as.factor(c("gato","gato","gato","perro",
                            "perro","perro","perro", "buho","buho","buho",
                            "buho","tigre","tigre","tigre",NA,"tigre"))
admissionList.simpleCheckHour<-c("08:56:20",NA,"07:25:15",NA,
                                 "08:56:45","08:18:13","10:38:26","03:52:38","12:41:55",
                                 "02:32:58",NA,"03:58:37","03:58:37","06:21:46",
                                 "06:21:46","08:56:20")
simpleOriginDate<-c("01/03/2020","02/03/2020","03/03/2020",
                    "04/03/2020","05/03/2020","06/03/2020","07/03/2020",
                    "08/03/2020","09/03/2020","10/03/2020","11/03/2020",
                    "12/03/2020","13/03/2020","14/03/2020","15/03/2020",
                    "16/03/2020")

df1<-data.frame(surgeon.lastname,specialty.name,
                admissionList.simpleCheckHour, simpleOriginDate)
# 修复赋值错误，将<改为<-
df1$admissionList.simpleCheckHour <- hms::as_hms(df1$admissionList.simpleCheckHour)
df1$simpleOriginDate<-as.Date(df1$simpleOriginDate, "%d/%m/%Y")

# UI代码
ui <- fluidPage(
  titlePanel("时间范围筛选测试"),
  sidebarLayout(sidebarPanel(
    uiOutput("SeleccioneEspecialidad2"),
    uiOutput("Rango"),
    uiOutput("RandeDatedI")
    
  ),
  mainPanel(
    DTOutput("t1"),
    DTOutput("summary9")
  )))

# 服务端代码
server <- function(input, output, session) {
  
  output$SeleccioneEspecialidad2<-renderUI({
    choices <- na.omit(df1$specialty.name)
    selectInput("SeleccioneEspecialidad2", "Seleccione Especialidad",
                choices=choices, multiple = T, selected = TRUE )
  })
  
  BD9<-reactive({
    req(input$SeleccioneEspecialidad2)
    df1 %>%
      filter(specialty.name %in% input$SeleccioneEspecialidad2 ) %>%
      filter(admissionList.simpleCheckHour >= hms::hms(0, 30, 6), admissionList.simpleCheckHour <= hms::hms(0, 0, 9))
  })
  
  FechaI<-reactive({
    unique(BD9()$simpleOriginDate)
  })
  
  output$RandeDatedI <-renderUI({
    req(FechaI())
    mymin <- min(FechaI(),na.rm=T)
    mymax <- max(FechaI(),na.rm=T)
    dateRangeInput('dateRangeI',
                   label = 'Seleccione un rango',
                   start = mymin, end = mymax,
                   min = mymin, max = mymax
    )
  })
  BD9.3<-reactive({
    req(input$dateRangeI, BD9())
    BD9() %>%
      filter(simpleOriginDate >= input$dateRangeI[1] & simpleOriginDate <= input$dateRangeI[2])
  })
  hora<-reactive({
    unique(BD9.3()$admissionList.simpleCheckHour)
  })
  output$Rango<-renderUI({
    req(hora())
    # 转换为POSIXct时指定统一origin基准
    minn=min(as.POSIXct(hora(), origin = "1970-01-01"), na.rm = T)
    maxx=max(as.POSIXct(hora(), origin = "1970-01-01"), na.rm = T)
    sliderInput("Rango",label = "Seleccione un rango", min = minn, max=maxx,
                value=c(minn,maxx),
                timeFormat = "%H:%M:%S", # 仅显示时分秒
                step = 60) # 步长设为60秒，即1分钟
  })
  BD9.5<-reactive({
    req(input$Rango, BD9.3())  
    BD9.3() %>%
      filter(admissionList.simpleCheckHour>= hms::as_hms(input$Rango[1])  &
               admissionList.simpleCheckHour <= hms::as_hms(input$Rango[2])) 
  })
  
  BD96 <- reactive({
    # 修复未定义的BD91()，替换为BD9()
    req(BD9.5(),BD9())
    dfsub <- BD9.5() %>% count(specialty.name)
    df1 <- BD9() %>% count(specialty.name) %>% rename(den=n)
    df3 <- dplyr::left_join(dfsub, df1, by=c("specialty.name"),all=TRUE) %>% mutate(Porcentaje = (n/den)*100) %>% select(1,2,4)
    df3
  })
  output$t1 <- renderDT(datatable(BD9.3()))
  
  output$summary9<-renderDT({
    datatable(BD9.5(), class = 'cell-border stripe', options = list(
      order = list(list(3, 'desc'))))
  })
}
shinyApp(ui, server)

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