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)
- Converting the row of a data.table to a vector
- ggplot multi-line log-log labels
- dplyr filter vector by position in pipe %>%
- Removing white spaces in a histogram?
- How to assign and match land cover type from Corine to a dataframe with a set of lon lat coordinates?
- Error in list2env(list, envir = .GlobalEnv) : names(x) must be a character vector of the same length as x
- How to traverse hclust internal node in R
- How are the abbreviations from the par function like mgp, mar, mai, deciphered?
- How to map over function with multiple arguments (and changing data)?
- Join/fill in data based on both row and column values
- How to plot a Log Pearson III distribution using `ggplot2` in R?
- Variable names and Easystats reports
- R plotly(): Adding regression line to a correlation scatter plot
- How to Use ifelse Statements in R
- Creating subgraphs from neighbors with max weight in R using igraph
- merge based on id and dates with missing data
- Automatically adjust the size of the text inside each bar on a bar plot using ggplot2 in R
- gghighlight and facet_wrap one always highlighted
- Mask and Crop functions in Terra R
- How to use a variable in dplyr::filter?
- Changing R Temporary Files
- How do you add a general label to facets in ggplot2?
- change colour of controls in R DT datatable
- Click Button Within Datatable to Display Popup Twice in a row
- How to display values in filter with ascending order
- Select Data From Column in Data Table
- Warning: Error in dataTableOutput: unused argument (height = "auto")
- How to have cells with rounded corners in {gt}?
- Two colours in the same box
- Change color of datatable filter dropdown box