How to connect dateRangeInput and sliderInput in R-Shiny - r

Question

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?

Answer 1

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)