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")
})
}
))
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 have the following code that should ask for a date and a time and then merge them together to get a date-time variable, if possible POSIXct.
library(shiny)
library(shinyTime)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
dateInput(inputId='dateRange1',
label = 'Enter initial date: yyyy-mm-dd'),
timeInput("time_input1", "Enter time of the initial day", value = strptime("00:00:00", "%T"))
),
mainPanel(
textOutput("time_output1")
)))
################
server <- function(input, output) {
vals <- reactiveValues()
observe({
vals$initial_date <-paste(as.character(input$dateRange1),strftime(input$time_input1, "%T") , collapse = " - ")
})
output$time_output1 <- renderText(vals$initial_date)
}
shinyApp(ui, server)
I would like the class of vals$initial_date to be "POSIXct" "POSIXt", but I do not manage. I need to make operations with the dates and times. I have tried many things, among other ones I have used:
vals$initial_date<- strptime(vals$initial_date, "%d-%m-%Y %H:%M:%S")
and
vals$initial_date<- as.POSIXct(vals$initial_date, "%d-%m-%Y %H:%M:%S")
inside the 'observe', but it did not work.
Can someone please tell me where my problem is?
thanks!
The time input already has the date component, we can get rid of it if you like. Note that I have added the inherits test to see if the object in the reactiveValues() is of type POSIXct. Also I added some renderText conditional so it displays full datetime oppose to just date when rendering 00:00:00
library(shiny)
library(shinyTime)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
dateInput(inputId='dateRange1',label = 'Enter initial date: yyyy-mm-dd ', value = Sys.Date()),
timeInput("time_input1", "Enter time of the initial day", value = strptime("00:00:00", "%T"))
),
mainPanel(
textOutput("time_output1")
)))
################
server <- function(input, output) {
vals <- reactiveValues()
observe({
testdatetime <- paste(input$dateRange1,strftime(input$time_input1, format="%H:%M:%S"))
testdatetime <- as.POSIXct(testdatetime, format="%Y-%m-%d %H:%M:%S",tz= "UTC")
vals$initial_date <- testdatetime
# Check if the Time is a POSIXct object
test <- inherits(testdatetime, "POSIXct")
print(test)
})
output$time_output1 <- renderText({
value <- as.character(vals$initial_date)
if(nchar(value) == nchar(as.character(Sys.Date()))){
value <- paste(value,"00:00:00 ")
}
value
})
}
shinyApp(ui, server)
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)
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
})
})