Shiny应用dateRangeInput日期范围错误处理失效问题求助

我开发的Shiny应用使用dateRangeInput()筛选data.table数据，当误将结束日期设为早于起始日期时，R控制台会抛出Error in seq.int: incorrect sign of argument 'by'错误。我添加了错误处理逻辑，首次触发该错误时自定义警告弹窗正常弹出，但添加更多数据行后再次触发，就会抛出系统错误而非自定义警告。

原代码 #

library(shiny)
library(shinydashboard)
library(rhandsontable)
library(data.table)
library(lubridate)
library(shinyalert)

df <- data.table(
  "Date" = as.character(NA),
  "Col1" = as.character(NA),
  stringsAsFactors = FALSE
)

ui <- fluidPage(
  dashboardPage(
   dashboardHeader(),
   dashboardSidebar(
      sidebarMenu(
        menuItem("Trial", tabName = "trial")
      )
    ),
    dashboardBody(
      tabItems(
        tabItem(tabName = "trial",
          fluidRow(
            column(
              width = 8,
              dateRangeInput("date", label=NULL,
                     start = "2024-01-01", end = Sys.Date()),
              uiOutput("nested_ui")
            ),
            column(
              width = 8,
              rHandsontableOutput("table")
            )
          )
        )
      )
    )
  )
)

server = function(input, output, session) {

  r <- reactiveValues(
    start = ymd("2024-01-01"),
    end = ymd(Sys.Date())
  )

  data <- reactiveValues()

  observe({
    data$dt <- as.data.table(df)
  })

  observe({
    if (!any(is.na(input$date))) {
      selectdates1 <- seq.Date(from=as.Date(input$date[1L]),
                              to=as.Date(input$date[2L]), by = "day")
      data$dt1 <- data$dt[as.Date(data$dt$Date) %in% selectdates1, ]
    } else {
      selectdates2 <- unique(as.Date(data$dt$Date))
      data$dt1 <- data$dt[data$dt$Date %in% selectdates2, ]
    }
  })

  observeEvent(input$date, {
    start <- ymd(input$date[[1]])
    end <- ymd(input$date[[2]])
    if (start >= end) {
      shinyalert("Input error: end date > start date", type = "error")
      updateDateRangeInput(
        session, 
        "date", 
        start = r$start,
        end = r$end
      )
    } else {
      r$start <- input$date[[1]]
      r$end <- input$date[[2]]
    }
  }, ignoreInit = TRUE)

  output$nested_ui <- renderUI({
    !any(is.na(input$date))
  })

  output$table <- renderRHandsontable({
    rhandsontable(data$dt1, stretchH = "all", height = 200) |>
    hot_col(1, dateFormat="YYYY-MM-DD", type="date")
  })

}

shinyApp(ui, server)

问题根源 #

1. observe执行顺序不确定性：处理日期筛选的observe块和错误处理的observeEvent(input$date)执行顺序没有保障。用户输入错误日期时，筛选逻辑可能先于错误处理执行，直接用错误的日期范围调用seq.Date()触发系统错误。
2. 数据更新后的依赖触发：添加数据行后，data$dt更新会重新触发筛选observe块，若此时input$date仍处于错误状态，会直接执行报错逻辑。

修复方案 #

方案1：在筛选逻辑中直接加入合法性校验

修改筛选数据的observe块，先判断日期范围是否合法，避免调用seq.Date()时出错：

observe({
  if (!any(is.na(input$date))) {
    start_date <- as.Date(input$date[1L])
    end_date <- as.Date(input$date[2L])
    # 先校验日期合法性
    if (start_date <= end_date) {
      selectdates1 <- seq.Date(from=start_date, to=end_date, by = "day")
      data$dt1 <- data$dt[as.Date(data$dt$Date) %in% selectdates1, ]
    } else {
      # 日期不合法时，保持当前显示的数据集
      data$dt1 <- data$dt1
      # 也可以选择显示全部数据：data$dt1 <- data$dt
    }
  } else {
    selectdates2 <- unique(as.Date(data$dt$Date))
    data$dt1 <- data$dt[data$dt$Date %in% selectdates2, ]
  }
})

方案2：用reactiveValues存储合法日期范围，筛选逻辑仅依赖合法值

将经过校验的日期范围单独存储，筛选逻辑只使用这个合法值，彻底避免接触错误的输入值：

server = function(input, output, session) {
  # 存储经过校验的合法日期范围
  valid_dates <- reactiveValues(
    start = ymd("2024-01-01"),
    end = ymd(Sys.Date())
  )

  data <- reactiveValues()

  # 仅初始化一次数据，避免重复重置
  observe({
    if (is.null(data$dt)) {
      data$dt <- as.data.table(df)
    }
  })

  # 筛选逻辑仅依赖valid_dates，不再直接使用input$date
  observe({
    selectdates1 <- seq.Date(from=valid_dates$start, to=valid_dates$end, by = "day")
    data$dt1 <- data$dt[as.Date(data$dt$Date) %in% selectdates1, ]
  })

  observeEvent(input$date, {
    start <- ymd(input$date[[1]])
    end <- ymd(input$date[[2]])
    if (start >= end) {
      shinyalert("输入错误：结束日期不能早于起始日期", type = "error")
      updateDateRangeInput(
        session, 
        "date", 
        start = valid_dates$start,
        end = valid_dates$end
      )
    } else {
      valid_dates$start <- start
      valid_dates$end <- end
    }
  }, ignoreInit = TRUE)

  # 移除无效的nested_ui输出，或补充实际UI内容
  # output$nested_ui <- renderUI({ ... })

  output$table <- renderRHandsontable({
    rhandsontable(data$dt1, stretchH = "all", height = 200) |>
    hot_col(1, dateFormat="YYYY-MM-DD", type="date")
  })

}

内容的提问来源于stack exchange，提问作者firuz.safaev