I spent quite a while trying to figure out how to add back/next week button around the daterangeinput field in Shiny. I personally think it is a cool and handy feature and it seems that there is no similar question/answer on stackoverflow (correct me if I'm wrong and I will delete this post).
Here is a screenshot so you know what I am talking about:
Here is a list of features I could think of when I design the code.
1. When you hit back/next buttons, both dates will move backward/forward
2. Back/Next should use the gap between the two dates to jump around
3. When the date on the left hits the minimum dates and you hit back, that date won't decrease anymore but the date on the right side will still decrease until it hits the minimum dates as well
4. When both dates equals to each other at the minimum date, when you hit Next, the date on the right side will increase by 7 (a week) by default.
5. Vice versa for the right side.
I put my code on a public gist.
shiny::runGist("https://gist.github.com/haozhu233/9dd15e7ba973de82f124")
server.r
library(shiny)
shinyServer(function(input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
date.range <- as.Date(c("2015-01-01", "2015-12-31"))
# ------- Date Range Input + previous/next week buttons---------------
output$choose.date <- renderUI({
dateRangeInput("dates",
label = h3(HTML("<i class='glyphicon glyphicon-calendar'></i> Date Range")),
start = "2015-05-24", end="2015-05-30",
min = date.range[1], max = date.range[2])
})
output$pre.week.btn <- renderUI({
actionButton("pre.week",
label = HTML("<span class='small'><i class='glyphicon glyphicon-arrow-left'></i> Back</span>"))
})
output$next.week.btn <- renderUI({
actionButton("next.week",
label = HTML("<span class='small'>Next <i class='glyphicon glyphicon-arrow-right'></i></span>"))
})
date.gap <- reactive({input$dates[2]-input$dates[1]+1})
observeEvent(input$pre.week, {
if(input$dates[1]-date.gap() < date.range[1]){
if(input$dates[2]-date.gap() < date.range[1]){
updateDateRangeInput(session, "dates", start = date.range[1], end = date.range[1])
}else{updateDateRangeInput(session, "dates", start = date.range[1], end = input$dates[2]-date.gap())}
#if those two dates inputs equal to each other, use 7 as the gap by default
}else{if(input$dates[1] == input$dates[2]){updateDateRangeInput(session, "dates", start = input$dates[1]-7, end = input$dates[2])
}else{updateDateRangeInput(session, "dates", start = input$dates[1]-date.gap(), end = input$dates[2]-date.gap())}
}})
observeEvent(input$next.week, {
if(input$dates[2]+date.gap() > date.range[2]){
if(input$dates[1]+date.gap() > date.range[2]){
updateDateRangeInput(session, "dates", start = date.range[2], end = date.range[2])
}else{updateDateRangeInput(session, "dates", start = input$dates[1]+date.gap(), end = date.range[2])}
}else{if(input$dates[1] == input$dates[2]){updateDateRangeInput(session, "dates", start = input$dates[1], end = input$dates[2]+7)
}else{updateDateRangeInput(session, "dates", start = input$dates[1]+date.gap(), end = input$dates[2]+date.gap())}
}})
output$dates.input <- renderPrint({input$dates})
})
#------- End of Date range input -----------------
ui.r
library(shiny)
shinyUI(
navbarPage("Demo",
position = "static-top",
fluid = F,
#================================ Tab 1 =====================================
tabPanel("Demo",class="active",
sidebarLayout(
sidebarPanel(uiOutput("choose.date"),
tags$div(class="row",
tags$div(class="col-xs-6 text-center", uiOutput("pre.week.btn")),
tags$div(class="col-xs-6 text-center", uiOutput("next.week.btn")))
),
mainPanel = (
textOutput("dates.input")
)
))))
Related
I built an app in R Shiny which uses time series data that excludes many dates. Within the app a user can select a new dataset, so the dates available will change. I'm using updateDateInput to update the dateInput selector. However, updateDateInput does not seem to allow the datesdisabled function?
Here is a reprex:
library(shiny)
# Sample 3 dates and disable the rest
my_dates <- sample(seq(as.Date('2021-01-01'), as.Date('2021-01-31'), by = "day"), 3)
date_choices <- seq.Date(from = min(my_dates), to = max(my_dates), by = 1)
dates_disabled <- date_choices[!(date_choices %in% my_dates)]
ui <- fluidPage(
dateInput("date", "Select Date",
min = min(date_choices),
max = max(date_choices),
value = max(date_choices),
datesdisabled = dates_disabled),
actionButton("click", "Click Me")
)
server <- function(input, output, session) {
observeEvent(input$click, {
my_dates <- sample(seq(as.Date('2021-01-01'), as.Date('2021-01-31'), by = "day"), 3)
date_choices <- seq.Date(from = min(my_dates), to = max(my_dates), by = 1)
dates_disabled <- date_choices[!(date_choices %in% my_dates)]
updateDateInput(
session,
"date",
min = min(date_choices),
max = max(date_choices),
value = max(date_choices),
datesdisabled = dates_disabled)
})
}
shinyApp(ui, server)
When the button is clicked and the updateDateInput runs, I get this error:
Warning: Error in updateDateInput: unused argument (datesdisabled =
dates_disabled)
I guess there is the option of changing the date to a character and using selectInput? But then I don't get the nice calendar!
You are right, the datesdisabled argument is not available in the update function. You can change the disabled dates by moving the UI declaration into the server and feed it to the client with renderUI().
The sample does not declare the date input in the UI but a uiOutput("date"). The server can dynamically create the dateInput using the datesdisabled argument. This way you can change the disabled dates.
The example will pick only 3 enabled dates after every button click.
# Reprex: The actual implementation of this uses data from a file:
# 1. Reads data file before ui and server are established
# 2. Does a bunch of calculations
# 3. Identifies dates that exist in data file
# 4. The data file is getting updated in the background from another application.
# 5. Allows user to click the button to update the data file. Reprex shows code
# that is used to update the date selector based on new data read. Dates are
# random in reprex, but would come from data file in actual code.
# Sample 3 dates and disable the rest - actual code reads data file here
# and parses out dates that exist in records
my_dates <- seq(as.Date('2021-01-01'), as.Date('2021-01-31'), by = "day")
date_choices <- sample(my_dates, 31-3)
ui <- fluidPage(
uiOutput("date"), textOutput("disabled"),
actionButton("click", "Click Me")
)
server <- function(input, output, session) {
dates_disabled <- reactiveVal(NULL)
# Init 'dates_disabled()' once before Shiny flushes the reactive system with callback,
# using date_choices that exist in original data set
onFlush(fun = function () {dates_disabled(date_choices)}, once = TRUE)
# dateInput widget
output$date <- renderUI({
maxDate <- as.Date(max(setdiff(my_dates, dates_disabled())),
origin = "1970-01-01")
dateInput(input = "date",
label = "Select Date",
min = min(my_dates),
max = max(my_dates),
value = maxDate,
datesdisabled = dates_disabled())
})
# This output makes it easier to test if it works by showing the enabled dates
output$disabled <- renderPrint({
req(dates_disabled()) # only run this when 'dates_disabled' is initialized properly
Enabled <- as.Date(setdiff(seq(as.Date('2021-01-01'), as.Date('2021-01-31'), by = "day"),
dates_disabled()),
origin = '1970-01-01')
paste("Enabled:", paste(Enabled[order(Enabled)], collapse = ", "))
})
# Set new datesdisabled on button click
# Actual code would read updated data file and parse new dates
observeEvent(input$click, {
SelectedDates <- sample(my_dates, 31-3)
dates_disabled( SelectedDates )
})
}
shinyApp(ui, server)
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")
})
}
))