For testing, please upload a csv file with 1+ column that can be converted to Date in the app.
My app generates date range inputs (input$daterange) dynamically depending on the date columns selected. I'd like to validate each input$daterange from 1 to n (the length of dt$datecols) to make sure the user won't select start date earlier than the oldest date, and end date later than the latest date in the corresponding column. I use lapply on observeEvent to do that.
For ease of debugging, I pass the value of input$daterange(i) to reactive values dt$daterange(i) and print dt$daterange1 (the first date range's value) to the console rendered to check whether the it is smaller or bigger than the min and max of the corresponding date column, as I did in the lapply function. Supposedly, when the check result is FALSE, lappy function shall display an error message warning the user the start or end date is not valid, which, however doesn't work. Please find my code below, please check the comments for explanation of problem.
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)
