Shiny App ignores some URL parameters with reactive inputs

[dmawhirter]

Reposting from Stack Overflow, where I got no engagement: r - Shiny App ignores some URL parameters with reactive inputs - Stack Overflow

I've built a shiny app where one dropdown depends on the selections made in another dropdown, because one category is a subset of another. In the example below, I've added code to parse URL parameters and update the inputs accordingly, so that users can save and share their visualizations and other code can generate automatic links to the app. Unfortunately, the URL input to the reactive dropdown (Cat2 in the code below) seems to get lost, I think because the dropdown is refreshed in response to the URL input to the non-reactive dropdown (Cat1 below). Is there some way to preserve this URL input even after the dropdown input is refreshed?

Note: the reproducible example below also includes the date slider input because the Cat2 dropdown needs to stay reactive to the date slider but retain the user's selection when the date slider changes.

The example below creates a working app but the Cat2 dropdown does not keep the URL inputs. To reproduce, use runApp() on the code below or click the Run App button in RStudio, click Open in Browser in RStudio's rendering of the app, and then append "/?Cat1Input=b&Cat2Input=F" to the end of the IP address URL. If you just append "/?Cat2Input=D" you will see that Cat2 input is working as intended as long as Cat1 does not have a URL input

library("shiny")

faithful$date <- as.Date(c(as.Date("2022-01-01"):as.Date("2022-12-31")),
                         origin="1970-01-01")[1:nrow(faithful)]
faithful$cat1 <- c(rep("a",nrow(faithful)*.5),
                   rep("b",nrow(faithful)*.5))
faithful$cat2 <- c(rep("C",nrow(faithful)*.25),
                   rep("D",nrow(faithful)*.25),
                   rep("E",nrow(faithful)*.25),
                   rep("F",nrow(faithful)*.25))

assign(x="serverCat1", value=NULL, envir=.GlobalEnv)
assign(x="serverCat2", value=NULL, envir=.GlobalEnv)
assign(x="serverStartDate", value=min(faithful$date), envir=.GlobalEnv)
assign(x="serverEndDate", value=max(faithful$date), envir=.GlobalEnv)

ui <- fluidPage(
  
  # Sidebar layout with input and output definitions ----
  sidebarLayout(
    
    # Sidebar panel for inputs ----
    sidebarPanel(
      
      sliderInput(inputId = "DateInput",
                  label = "Date",
                  min = as.Date(min(faithful$date)),
                  max = as.Date(max(faithful$date)),
                  value = c(as.Date(get("serverStartDate",envir = .GlobalEnv)),
                            as.Date(get("serverEndDate",envir =.GlobalEnv))),
                  timeFormat = "%Y-%m-%d"),
      
      selectInput(inputId = "Cat1",
                  label = "Category 1",
                  choices = unique(as.character(faithful$cat1)),
                  multiple = FALSE),
      
      uiOutput("Cat2Selection")
      
    ),
    
    # Main panel for displaying outputs ----
    mainPanel(
      
      # Output: Histogram ----
      plotOutput(outputId = "distPlot")
      
    )
  )
)

# Define server logic required to draw a histogram ----
server <- function(input, output, session) {
    
  observe({
    query <- parseQueryString(session$clientData$url_search)
    if (!is.null(query[["Cat1Input"]])) {
      cat1 = query[["Cat1Input"]]
      updateSliderInput(session,"Cat1",value = cat1)
      assign("serverCat1Input", value=query[["Cat1Input"]], envir=.GlobalEnv)
    }
    if (!is.null(query[["Cat2Input"]])) {
      updateSliderInput(session,"Cat2",value = query[["Cat2Input"]])
      assign("serverCat2Input", value=query[["Cat2Input"]], envir=.GlobalEnv)
    }
    #this will change the start and end date
    if (!is.null(query[["StartDate"]])){
      if (!is.null(query[["EndDate"]])){
        updateSliderInput(session,"DateInput", value = c(as.Date(query[["StartDate"]]),as.Date(query[["EndDate"]])))
        assign("serverEndDate",value = query[["EndDate"]], envir=.GlobalEnv)
      } else {
        updateSliderInput(session,"DateInput",value = as.Date(query[["StartDate"]]))
        assign("serverStartDate",value = query[["StartDate"]], envir=.GlobalEnv)
      }
    }
  })
    
  
  output$Cat2Selection <-renderUI({
    
    if (!is.null(get("serverCat2",envir=.GlobalEnv))) {
      Cat2 <- get("serverCat2",envir=.GlobalEnv)
    } else {
      Cat2 <- input$Cat2
    }
    
    selectInput(inputId = "Cat2",
                label = "Category 2",
                choices = unique(faithful$cat2[faithful$cat1 == input$Cat1 &
                                                 faithful$date <= max(input$DateInput) &
                                                 faithful$date >= min(input$DateInput)]),
                selected = Cat2,
                multiple = FALSE)
  })

  
  output$distPlot <- renderPlot({
    
    x    <- faithful$waiting[faithful$date <= max(input$DateInput) & 
                               faithful$date >= min(input$DateInput) & 
                               faithful$cat1 == input$Cat1 &
                               faithful$cat2 == input$Cat2]
    
    hist(x, breaks = 30, col = "#007bc2", border = "white",
         xlab = "Waiting time to next eruption (in mins)",
         main = "Histogram of waiting times")
    
  })
  
}

#running the shiny app
shinyApp(ui = ui, server = server, enableBookmarking = "url")