要进行测试，请上传一个包含1+列的csv文件，该列可在应用中转换为日期。
我的应用根据所选的日期列动态生成日期范围输入（input$daterange）。我想从1到n（input$daterange的长度）验证每个dt$datecols，以确保用户不会在最早的日期之前选择start日期，end的日期晚于相应列中的最新日期。我在lapply上使用observeEvent来执行此操作。
为了便于调试，我将input$daterange(i)的值传递给被动值dt$daterange(i)并将dt$daterange1（第一个日期范围的值）打印到提供给检查的控制台以进行检查它是否小于或大于相应日期列的min和max，就像我在lapply函数中所做的那样。据推测，当检查结果为FALSE时，lappy函数会显示一条错误消息，警告用户start或end日期无效，但不是工作。请在下面找到我的代码，请查看评论以解释问题。
library("shiny")
library("DT") # Datatable
library("rsconnect") # deploy to shinyapps.io
library("shinyjs") # use toggle button from shinyJS pacakage
library("stats")
library("zoo") # to use as.Date() on numeric value
ui <- fluidPage(
fluidRow(
column(4,
# file upload div
fileInput("file", "Choose a file",
accept=c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv"
)),
# show ui for upload file control
uiOutput("ui")
),
column(4,
# no choices before a file uploaded
uiOutput("columnscontrol")
)
),
hr(),
fluidRow(
column(4,
uiOutput("datecolscontrol")),
column(6,
uiOutput("daterangescontrol"))
),
hr(),
dataTableOutput("datatbl"),
# print console for debugging (delete after completion)
verbatimTextOutput("print_con")
) #end of fluidPage (ui)
# server
server <- function(input, output, session) {
#########################################################
# upload & datatable output
#########################################################
# create dataset reactive objects
dt <- reactiveValues()
# reset all uis upon new file upload
observeEvent(input$file, {
# reset reactive values
dt$data = NULL
dt$df = NULL
dt$cols = NULL
dt$rows = NULL
dt$summary = NULL
dt$colchoices = NULL
dt$datecols = NULL
# remove columns div and datecols div when a new file uploaded
removeUI(selector = "div#columns_div")
removeUI(selector = "div#datecols_div")
# remove all <div> elements indside <div>#daterangescontrol:
removeUI(selector = "div#daterangescontrol div")
# generate upload file control ui once file uploaded
output$ui <- renderUI({
actionButton("readF", "Update")
})
})
# when read file button pressed:
observeEvent (input$readF, {
# store data to dt$data
file <- input$file
dt$data <- read.csv(file$datapath, header = TRUE)
# render columnscontrol
output$columnscontrol <- renderUI({
# get the col names of the dataset and assign them to a list
dt$colchoices <- mapply(list, names(dt$data))
# render column group checkbox ui after loading the data
# tags#div has the advantage that you can give it an id to make it easier to reference or remove it later on
tags$div(id = "columns_div",
checkboxGroupInput("columns", "", choices = NULL, selected = NULL))
})
# render div containing #datecols under datecolscontrol
output$datecolscontrol <- renderUI({
tags$div(id = "datecols_div",
selectInput("datecols", "Filter data by dates):", choices = NULL, multiple = TRUE, selected = NULL))
})
})
# update columns choices when dt$choices is ready
observeEvent(dt$colchoices, {
updateCheckboxGroupInput(session, "columns", "Select Columns:", choices = dt$colchoices, selected = dt$colchoices)
})
# the other reactivity on dt$cols is input$file (when new file uploaded, dt$data and dt$cols set to NULL)
# so that the following line set apart the reactivity of input$columns on dt$cols
observeEvent(input$columns, {
dt$cols <- input$columns
dt$df <- dt$data[dt$cols]
}, ignoreNULL = FALSE)
# upon any change of dt$df
observeEvent(dt$df, {
f <- dt$df
# render output$datatbl
output$datatbl <- DT::renderDataTable(
f, rownames = FALSE,
filter = 'top',
options = list(autoWidth = TRUE)
)
# update datecols choices with those columns can be converted to Date only:
dt$date_ok = sapply(f, function(x) !all(is.na(as.Date(as.character(x), format = "%Y-%m-%d"))))
dt$datecolchoices = colnames(f[dt$date_ok])
updateSelectInput(session, "datecols", "Filter data by dates:", choices = dt$datecolchoices, selected = NULL)
}, ignoreNULL = FALSE)
# whenver columns convertable to date updated to choices of input$datecols, convert the columns to Date in the dataset
observeEvent(dt$datecolchoices, {
dt$df[dt$date_ok] = lapply(dt$df[dt$date_ok], function(x) as.Date(as.character(x)))
})
# generate daterange uis per selected input$datecols
observeEvent(input$datecols, {
dt$datecols = input$datecols
dt$datecols_len = length(dt$datecols)
# render daterange ui(s) per selected datecols
output$daterangescontrol <- renderUI({
# when input$datecols is NULL, no daterange ui
if ( is.null(input$datecols) ) { return(NULL) }
# otherwise
else {
D = dt$df[dt$rows, dt$cols]
output = tagList()
for (i in 1:dt$datecols_len) {
output[[i]]= tagList()
output[[i]][[1]] = tags$div(id = paste("dateranges_div", i, sep = "_"),
dateRangeInput(paste0("daterange", i),
paste("Date range of", dt$datecols[[i]]),
start = min(D[[dt$datecols[[i]]]]),
end = max(D[[dt$datecols[[i]]]])))
}
# return output tagList() with ui elements
output
}
}) # end of renderUI
}, ignoreNULL = FALSE)
# loop observeEvent to check whether each input$daterange is valid:
#### why I can't just call lapply() without observe() as suggested in this post:
#### https://stackoverflow.com/questions/40038749/r-shiny-how-to-write-loop-for-observeevent
observe({
lapply( X = 1:dt$datecols_len,
FUN = function(i) {
observeEvent(input[[paste0("daterange", i)]], {
# update reactive values to test whether this loop is working
dt[[paste0("range",i)]] = input[[paste0("daterange", i)]]
range = dt[[paste0("range",i)]]
req(range)
#########################################
## CODE BLOCK WITH PROBLEM!!!
#########################################
# Why the following doesn't work, when I pick a date earlier than the oldest date
# no error message shows!
shiny::validate(
need( range[[1]] >= min(dt$df[[dt$datecols[[i]]]]), "The start date cannot be earlier than the oldest date!"),
need( range[[2]] <= max(dt$df[[dt$datecols[[i]]]]), "The end date cannot be later than the latest date!")
)
})
}
) # end of lapply
})
# rows displayed in input$datatbl (the rendered data table)
observeEvent( input$datatbl_rows_all, {
dt$rows <- input$datatbl_rows_all
})
#########################################################
# print console
#########################################################
output$print_con <- renderPrint({
req(input$daterange1)
list(
# to verify whether the observeEvent loop is working for input validation
# I used dt$range1 to check the first (input$daterange1) against the date range of the corresponding column of the dataset.
# It's supposed that when the check result is FALSE (either by selecting a start date earlier than the oldest date or selecting an end date later than the latest date),
# the code block with problem shall prompt an error message to warn the user
min(dt$range1) >= min(dt$df[[dt$datecols[[1]]]]),
max(dt$range1) <= max(dt$df[[dt$datecols[[1]]]])
)
})
} # end of shiny server function
shinyApp(ui = ui, server = server)
答案 0 :(得分：0)
这可能不是您正在寻找的确切答案，但我认为这可能会简化事情。我只需订购您的日期列，以便您选择最早和最新的日期。然后将开始日期和结束日期设置为这两个值（请参阅？dateRangeInput）。 Lubridate也是处理日期的好方法
答案 1 :(得分：0)