I would like to know if there was a trick to prevent users from setting the end date before the beginning date using dateRangeInput in Shiny (say the first date is "01-01-2016", the second date cannont go lower than that).
I tried by redefining the min and the max each time, but then I get stuck and cannot get my min back to its original value.
Here is an example. Basically it observes changes in start date and then update the dateRangeInput object dynamically. If the previously selected end date is earlier than the new start date, then the end date is updated. The minimum possible date is also updated so that user cannot select an end date earlier than start date.
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("Dynamically change dateRangeInput"),
sidebarLayout(
sidebarPanel(
dateRangeInput("date_range", "Range of dates")
),
mainPanel(
textOutput("text")
)
)
))
server <- shinyServer(function(input, output, session) {
# Update the dateRangeInput if start date changes
observeEvent(input$date_range[1], {
end_date = input$date_range[2]
# If end date is earlier than start date, update the end date to be the same as the new start date
if (input$date_range[2] < input$date_range[1]) {
end_date = input$date_range[1]
}
updateDateRangeInput(session,"date_range", start=input$date_range[1], end=end_date, min=input$date_range[1] )
})
output$text <- renderText({
validate(
need(input$date_range[2] >= input$date_range[1], "End date cannot be earlier than start date!")
)
input$date_range[2] >= input$date_range[1]
})
})
shinyApp(ui = ui, server = server)
Related
Is there a way to imitate the daysofweekdisabled found in dateInput?
I want people to select only mondays.
Unfortunately, there is no built-in feature of function dateRangeInput. However, one can create a hook to evaluate if a given input is valid or not i.e. both start and end date is on a Monday:
library(shiny)
library(lubridate)
ui <- fluidPage(
dateRangeInput("daterange1", "Date range:",
start = "2001-01-01",
end = "2010-12-31"
),
textOutput("daterange1_valid")
)
server <- function(input, output, session) {
output$daterange1_valid <- renderText({
is_valid <- all(input$daterange1 %>% map_lgl(~ wday(.x, label = TRUE) == "Mon"))
ifelse(is_valid, "valid", "not valid. Start and end must be on a Monday!")
})
}
shinyApp(ui, server)
Another way is to just use two dateInput elements instead. This will allow you to also color days other than Monday grey in the picker.
In my Shiny-app, I have to subset a dataframe by time. The most convenient Widget for me is a sliderInput, but I also want to allow for the possibility of selecting the specific dates from a calendar, just as I would do with dateRangeInput, because the dataset spans multiple years of daily data. I have tried to link the two of them, updating the slider when dateRange changes and vice versa using two separate renderUI(). Generally, this works well, but in some cases, I get stuck in an infinite loop where the slider and rangeInput invalidate each other constantly. The infinite loop only triggers after changes thorugh the slider.
My Approach so far looks like this:
output$dateRangeSliderUI <- renderUI({
date_range_input <- input$dateRangeInput
data <- isolate(dataset())
start_date <- default_start
end_date <- default_end
if (is.null(date_range_input)){
range_slider <- c(start_date, end_date)
} else {
range_slider <- date_range_input
}
sliderInput("dateRangeSlider",
label = "Date Range:",
value = range_slider,
min = min(data$Date),
max = max(data$Date),
step = 1,
timeFormat = "%F")
})
output$dateRangeInputUI <- renderUI({
date_range_slider <- input$dateRangeSlider
data <- isolate(dataset$regressions)
start_date <- default_start
end_date <- default_end
if (is.null(date_range_slider)){
range_input <- c(start_date, end_date)
} else {
range_input <- date_range_slider
}
dateRangeInput("dateRangeInput",
label = NULL,
start = range_input[1],
end = range_input[2],
min = min(data$Date),
max = max(data$Date))
})
As you can see, the two widgets are only reactive to changes in each other, and start_date and end_date account for errors during startup during which both of them are still NULL.
Can you help me, how I might avoid getting stuck in an infinite loop?
To avoid recursion you can use two reactiveVal to store last update time of sliderInput and dateRange.
Update is only done after a certain delay which ensures that this was manual :
library(shiny)
ui <- fluidPage(
sliderInput(
"slider",
"Slider",
min = Sys.Date() - 90,
max = Sys.Date(),
value = c(Sys.Date() - 30, Sys.Date())
),
dateRangeInput(
"daterange",
"Input date range",
start = Sys.Date() - 30,
end = Sys.Date()
)
)
server <- function(input, output, session) {
## Avoid chain reaction
reactdelay <- 1
change_slider <- reactiveVal(Sys.time())
change_daterange <- reactiveVal(Sys.time())
observeEvent(input$slider, {
if (difftime(Sys.time(), change_slider()) > reactdelay) {
change_daterange(Sys.time())
updateDateRangeInput(session,
"daterange",
start = input$slider[[1]],
end = input$slider[[2]])
}
})
observeEvent(input$daterange, {
if (difftime(Sys.time(), change_daterange()) > reactdelay) {
change_slider(Sys.time())
updateSliderInput(session,
"slider",
value = c(input$daterange[[1]], input$daterange[[2]]))
}
})
}
shinyApp(ui, server)
I've created a tiny Shiny app where the user is asked into how many periods s/he wants to cut a given vector of dates (between 2 and 4). Then, for each time period the user wants to have (except for the last one) s/he is asked to select the last date of that time period.
The app is working, however, I am afraid some foolish user might select end dates that are not incremental, e.g., the selected end date for Time Period 1 might be later in time than the end date selected for Time Period 2, etc.
In other words, I'd love to make choices (dates) available to user while defining cutpoint2 to contain only dates that come AFTER the cutpoint1 date, etc. So, if the user selected '2006-12-31' as the end date for Time Period 1, I'd like the dates available for user input box for Time Period 2 to start AFTER that date.
However, I am not sure it's even possible in this super-dynamic situation because first, I create those cutpoint inputs for the first time - when the user hasn't even been asked about dates at all, so I can't make them really dependent on each other. And then I ask the user to define the cut points - and then I'd like that dynamic to kick in.
Appreciate your advice!
library(shiny)
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
sidebarLayout(
sidebarPanel(
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 2, max = 4, value = 2),
uiOutput("period_cutpoints"),
actionButton("submit", "Update time periods")
),
mainPanel( # Just shows what was selected
textOutput("nr_of_periods"),
textOutput("end_dates")
)
)
))
server = shinyServer(function(input, output, session) {
library(lubridate)
output$nr_of_periods <- renderPrint(input$num_periodsnr)
# Dates string to select dates from:
dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')
output$period_cutpoints <- renderUI({
req(input$num_periodsnr)
lapply(1:(input$num_periodsnr - 1), function(i) {
selectInput(inputId = paste0("cutpoint", i),
label = paste0("Select the last date of Time Period ", i, ":"),
choices = dates)
})
})
dates_chosen <- reactiveValues(x = NULL)
observeEvent(input$submit, {
dates_chosen$x <- list()
lapply(1:(input$num_periodsnr - 1), function(i) {
dates_chosen$x[[i]] <- input[[paste0("cutpoint", i)]]
})
})
output$end_dates <- renderText({paste(as.character(dates_chosen$x), collapse = ", ")})
})
shinyApp(ui = ui, server = server)
Insert this into your server function:
observe({
if(input$num_periodsnr > 2){
for(i in 2:(input$num_periodsnr - 1)) {
updateSelectInput(session, paste0("cutpoint", i), choices = dates[dates > input[[paste0("cutpoint", i-1)]]])
}
}
})
Due to your lapply where you make new selectInput whenever you increase the number of periods, you (unintenionally) overwrite the previous results and reset the starting period, whenever a user goes from e.g. 3 to 4 cutpoint periods.
I have a shiny app where the user selects two date ranges, and a submit button
The first date range is for the analysis period, while the second date range is a range that should fall within the first date range.
I'm using dateRangeInput, and I want to set the min and max date for the second dateRangeInput equal to the user-selected time period from the first dateRangeInput. My problem right now is that the way I have it set up right now, the second dateRangeInput doesn't refresh until the user hits submit, whereas I'd like it to refresh as soon as the first dateRangeInput changes.
How do I achieve this?
So far my code looks like this:
#ui.R
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
dateRangeInput('inputDate', 'Select date range for analysis period', start = '2015-07-01', end = '2015-07-03', min = min_date, max = max_date),
#the output below is refreshing only when the user hits submit, but I would like it to refresh as soon as the first dateRangeInput changes.
uiOutput('return_dates'),
submitButton("Submit")
),
mainPanel()
)))
#server.R
shinyServer(function(input, output, session) {
ret_min <- reactive({
input$inputDate[1]
})
ret_max <- reactive({
input$inputDate[2]
})
output$return_dates <- renderUI({
dateRangeInput('inputDate2', 'Select date range for return period', start = '2015-07-01', end = '2015-07-02', min = ret_min(), max = ret_max())
})
analysisFunction <- reactive({
#code here performs analysis based on the given date range, and should run only when the user hits submit
})
})
I found a solution to this, which is to use actionButton rather than submitButton, which allows me to specify which functions should react only when the action button is hit, while the remaining functions will respond as soon as an input is changed.
#ui.R
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
dateRangeInput('inputDate', 'Select date range for analysis period', start = '2015-07-01', end = '2015-07-03', min = min_date, max = max_date),
uiOutput('return_dates'),
actionButton("submitButton","Submit")
),
mainPanel()
)))
#server.R
shinyServer(function(input, output, session) {
ret_min <- reactive({
input$inputDate[1]
})
ret_max <- reactive({
input$inputDate[2]
})
output$return_dates <- renderUI({
dateRangeInput('inputDate2', 'Select date range for return period', start = '2015-07-01', end = '2015-07-02', min = ret_min(), max = ret_max())
})
analysisFunction <- reactiveEvent({input$submitButton, {
#code here will only run when user hits submit
})
})
I have a date range input function as follows in my ui for my shiny app.
dateRangeInput("dates",
"Date range",
start = "2015-01-01",
end = as.character(Sys.Date()))
However I want a pop up message to correct the user if the user chooses a start date that is later than the end date, instead of an error in the app. How do i do this?
Also is it possible to only allow the user to choose a date range which is more than, say x, days.
You can provide custom error messages with a validate statement. Here is a simple example.
library(shiny)
runApp(
list(
ui = fluidPage(
dateRangeInput("dates",
"Date range",
start = "2015-01-01",
end = as.character(Sys.Date())),
textOutput("DateRange")
),
server = function(input, output){
output$DateRange <- renderText({
# make sure end date later than start date
validate(
need(input$dates[2] > input$dates[1], "end date is earlier than start date"
)
)
# make sure greater than 2 week difference
validate(
need(difftime(input$dates[2], input$dates[1], "days") > 14, "date range less the 14 days"
)
)
paste("Your date range is",
difftime(input$dates[2], input$dates[1], units="days"),
"days")
})
}
))