Empty dateRangeInput() is giving an error
My previous question 1 was about managing empty dateRangeInput(). My previous question 2 was about error-handling when an initial date is posterior to an end date.
I have integrated the solutions to both questions into one code and it is running well. But when a daterange input is fully erased by hand (i.e. when any of the date boxes is made empty) it is giving an Error in if: missing value, TRUE/FALSE is required.
Can someone show me what is wrong or missing in the code below?
library(shiny)
library(shinydashboard)
library(rhandsontable)
library(data.table)
library(dplyr)
library(lubridate)
library(shinyalert)
DF1 <- data.table(
"date" = as.character(NA),
"docname" = as.character(NA),
stringsAsFactors = FALSE)
DF2 <- data.table(
"date" = as.character(NA),
"docname" = as.character(NA),
stringsAsFactors = FALSE)
ui <- fluidPage(
dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Tab1", tabName = "table1")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "table1",
fluidRow(
column(
width = 8,
label=NULL,
rHandsontableOutput("table1Item1")
),
column(
width = 6,
label=NULL,
selectInput("choices", label=NULL,
choices = c("choice 1", "choice 2")),
uiOutput("nested_ui1")
),
column(
width = 8,
label=NULL,
rHandsontableOutput("table1Item2")
)
)
)
)
)
)
)
server = function(input, output, session) {
r <- reactiveValues(
start = ymd(Sys.Date()),
end = ymd(Sys.Date())
)
data <- reactiveValues()
observe({
data$df1 <- as.data.table(DF1)
data$df2 <- as.data.table(DF2)
})
observe({
if (!is.null(input$table1Item1)) {
data$df1 <- hot_to_r(input$table1Item1)
}
})
observe({
if(!is.null(input$table1Item2)) {
data$df2<- hot_to_r(input$table1Item2)
}
})
observeEvent(input$dates, {
start <- ymd(input$dates[[1]])
end <- ymd(input$dates[[2]])
if (start > end) {
shinyalert("Error: end date > initial date", type = "error")
updateDateRangeInput(
session,
"dates",
start = r$start,
end = r$end
)
} else {
r$start <- input$dates[[1]]
r$end <- input$dates[[2]]
}
}, ignoreInit = TRUE)
observe({ if (!is.null(input$table1Item1)) {
data$df1 <- hot_to_r(input$table1Item1)
if (!any(is.na(input$dates)) && input$choices == "choice 1") {
from=as.Date(input$dates[1L])
to=as.Date(input$dates[2L])
if (from>to) to = from
selectdates1_1 <- seq.Date(from=from, to=to, by = "day")
data$df2 <- data$df1[as.Date(data$df1$date) %in% selectdates1_1, ]
} else if (!is.null(input$text) && input$choices == "choice 2") {
data$df2 <- data$df1[data$df1$docname == input$text, ]
} else {
selectdates1_2 <- unique(data$df1$date)
data$df2 <- data$df1[data$df1$date %in% selectdates1_2, ]
}
}
})
output$table1Item1 <- renderRHandsontable({
rhandsontable(data$df1, stretchH = "all", height = 100,) |>
hot_col(1, dateFormat = "YYYY-MM-DD", type = "date")
})
output$nested_ui1 <- renderUI({
fluidRow(
if (input$choices == "choice 1") {
dateRangeInput("dates", "Choose date:", format="yyyy-mm-dd",
start = Sys.Date(), end = Sys.Date(), separator = "-")
} else if (input$choices == "choice 2") {
textInput("text", "Choose docname:")
})
})
output$table1Item2 <- renderRHandsontable({
rhandsontable(data$df2, stretchH = "all") |>
hot_col(1, dateFormat = "YYYY-MM-DD", type = "date")
})
}
shinyApp(ui, server)
Solution
The issue is that in your observeEvent(input$dates, ... you have the if condition if (start > end) and this can't handle things if start or end is NA (what is the case if the user clears the DateRangeInput).
You could circumvent this by using a tryCatch which in case of an error resets the DateRangeInput to Sys.Date() and throws a shinyalert that the DateRangeInput can't be empty and therefore was resetted, see the code below.
library(shiny)
library(shinydashboard)
library(rhandsontable)
library(data.table)
library(dplyr)
library(lubridate)
library(shinyalert)
DF1 <- data.table(
"date" = as.character(NA),
"docname" = as.character(NA),
stringsAsFactors = FALSE)
DF2 <- data.table(
"date" = as.character(NA),
"docname" = as.character(NA),
stringsAsFactors = FALSE)
ui <- fluidPage(
dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Tab1", tabName = "table1")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "table1",
fluidRow(
column(
width = 8,
label=NULL,
rHandsontableOutput("table1Item1")
),
column(
width = 6,
label=NULL,
selectInput("choices", label=NULL,
choices = c("choice 1", "choice 2")),
uiOutput("nested_ui1")
),
column(
width = 8,
label=NULL,
rHandsontableOutput("table1Item2")
)
)
)
)
)
)
)
server = function(input, output, session) {
r <- reactiveValues(
start = ymd(Sys.Date()),
end = ymd(Sys.Date())
)
data <- reactiveValues()
observe({
data$df1 <- as.data.table(DF1)
data$df2 <- as.data.table(DF2)
})
observe({
if (!is.null(input$table1Item1)) {
data$df1 <- hot_to_r(input$table1Item1)
}
})
observe({
if(!is.null(input$table1Item2)) {
data$df2<- hot_to_r(input$table1Item2)
}
})
observeEvent(input$dates, {
start <- ymd(input$dates[[1]])
end <- ymd(input$dates[[2]])
tryCatch({
if (start > end) {
shinyalert("Error: end date > initial date", type = "error")
updateDateRangeInput(session,
"dates",
start = r$start,
end = r$end)
} else {
r$start <- input$dates[[1]]
r$end <- input$dates[[2]]
}
}, error = function(e) {
updateDateRangeInput(session,
"dates",
start = ymd(Sys.Date()),
end = ymd(Sys.Date()))
shinyalert("DateRangeInput can't be empty! Resetting to Sys.Date().",
type = "error")
})
}, ignoreInit = TRUE)
observe({ if (!is.null(input$table1Item1)) {
data$df1 <- hot_to_r(input$table1Item1)
if (!any(is.na(input$dates)) && input$choices == "choice 1") {
from=as.Date(input$dates[1L])
to=as.Date(input$dates[2L])
if (from>to) to = from
selectdates1_1 <- seq.Date(from=from, to=to, by = "day")
data$df2 <- data$df1[as.Date(data$df1$date) %in% selectdates1_1, ]
} else if (!is.null(input$text) && input$choices == "choice 2") {
data$df2 <- data$df1[data$df1$docname == input$text, ]
} else {
selectdates1_2 <- unique(data$df1$date)
data$df2 <- data$df1[data$df1$date %in% selectdates1_2, ]
}
}
})
output$table1Item1 <- renderRHandsontable({
rhandsontable(data$df1, stretchH = "all", height = 100,) |>
hot_col(1, dateFormat = "YYYY-MM-DD", type = "date")
})
output$nested_ui1 <- renderUI({
fluidRow(
if (input$choices == "choice 1") {
dateRangeInput("dates", "Choose date:", format="yyyy-mm-dd",
start = Sys.Date(), end = Sys.Date(), separator = "-")
} else if (input$choices == "choice 2") {
textInput("text", "Choose docname:")
})
})
output$table1Item2 <- renderRHandsontable({
rhandsontable(data$df2, stretchH = "all") |>
hot_col(1, dateFormat = "YYYY-MM-DD", type = "date")
})
}
shinyApp(ui, server)
- grid.arrange's relative height argument didn't works well in RMarkdown
- How apply a function to every element of a matrix?
- Polar plot in R using ggplot2
- Find total length of time in multiple values of a dataset that overlaps with a given period of time
- Faster than R's `simplify2array`?
- What is the most simple way to label a data.table frequency chart in R?
- How to show dates in a secondary x-axis while the primary x-axis is numerical?
- online compiler for r-markdown document
- Unecessarily large column widths in HTML tables published by R Quarto when the table header contains special characters
- Bootstrapping a vector of results, by group in R
- Speeding Up Monte Carlo Simulations for Weather-Dependent Claims
- Is there an R class which allows to list 2 elements but shows only the first of them by default when called?
- Convert day of week number to weekday name in R
- How do you use "<<-" (scoping assignment) in R?
- Using reactivePoll to monitor and process file changes
- How to find out which graph is most similar to another graph?
- ggplot2: rectangular background behind axis text in circular bar plot
- How to simulate button click using rvest
- CMIP6, automating by month
- Covert dummy variables to single categorical in R?
- Animated reducing bar chart with gganimate
- Create an object class matrix/array from data frame
- How to add a vector of names to `sort_by()` in base R
- Among many subfolders, find CSVs starting with a given string and within ZIPs or not, and merge them while adding their names in a new column with R
- How to add a greek letter to an axis label to a 3D plot in plotly?
- bigrquery + dplyr error when using functions and sourcing from separate R script
- Shiny App Error: /v1/applications/ 400 - Validation Error Execution halted
- Rupee Unicode replacement not working in R
- Mutate multiple variable to create multiple new variables
- How to use the Stata equivalent of a foreach loop in R with mutate()