How to use updateSliderInput to change from point to range slider

Question

Within the following example (ignoring the var select logic for now), is it possible to use updateSliderInput to change the year slider type from one which takes a single value if input$slider_type == 'one' (the default), but a range of values if input$slider_type == 'two'?

If not, is the uiOutput/renderUI approach needed instead, or is there a third way?

library(tidyverse)
library(shiny)


dta <- tibble(
  var =
    c(
      rep("A", 10),
      rep("B", 3),
      rep("C", 5)
    ),
  year = c(
    1984:1993,
    1987:1989,
    1990:1994
  )
) %>%
  mutate(
    val = runif(n())
  )

ui <- fluidPage(

    titlePanel("Dynamic year slider"),

    sidebarLayout(
        sidebarPanel(
            selectInput(
              "var_select", "Select variable",
              choices = unique(dta$var)[1],
              selected = unique(dta$var)[1]
            ),
            selectInput("slider_type", "Select slider type",
                        choices = c("One value" = "one", "Two values" = "more"),
                        selected = "one"

                        ),
            sliderInput("year_select",
                        "Select year:",

                        min = min(subset(dta, var == unique(dta$var)[1])$year),
                        max = max(subset(dta, var == unique(dta$var)[1])$year),
                        value = min(subset(dta, var == unique(dta$var)[1])$year),
                        step = 1,
                        sep = ''

            )
        ),

        mainPanel(
           tableOutput("table_output")
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  current_var <- reactive(input$var_select)
  current_slider_type <- reactive(input$slider_type)
  current_year_value  <- reactive(input$year_select)

  observeEvent(input$var_select, {
    message("The selected var is ", current_var())
    freezeReactiveValue(input, "year_select")
    updateSliderInput(inputId = "year_select",
                      min = min(subset(dta, var == current_var())$year),
                      max = max(subset(dta, var == current_var())$year)

    )
  })

  observeEvent(input$slider_type, {
    this_slider_type <- current_slider_type()
    message("The current slider type is ", this_slider_type)
    if (this_slider_type == "more"){
      message("current_slider_type is more")

      updateSliderInput(inputId = "year_select",
                        label = "Select years", # this DOES update
                        value = c(1985, 1987) 
# Only the first value is passed through in the update
#the inclusion of a second value does not change the slider type from one which accepts only a single value, to one which accepts a range
      )
    } else if (this_slider_type == "one"){
      message("current_slider_type is one")
      updateSliderInput(inputId = "year_select",
                          label = "Select year",
                        value = 1986 # this DOES update 
      )

    }

  })


    output$table_output <- renderTable({
      req(input$year_select)
      dta %>%
        filter(var == input$var_select) %>%
        filter(year %in% input$year_select)
    })
}

# Run the application
shinyApp(ui = ui, server = server)

Answer 1

Many thanks to @ismishehregal for one solution. Another, related, solution I came across involves adapting an example from the Dynamic UI chapter in Mastering Shiny to show/hide tabset panels. Code included below for completeness of options

library(tidyverse)
library(shiny)


dta <- tibble(
  var =
    c(
      rep("A", 10),
      rep("B", 3),
      rep("C", 5)
    ),
  year = c(
    1984:1993,
    1987:1989,
    1990:1994
  )
) %>%
  mutate(
    val = runif(n())
  )

parameter_tabs <- tabsetPanel(
  id = "params",
  type = "hidden",
  tabPanel("one",
   sliderInput(
     "year_select",
     "Select year:",
     min = min(subset(dta, var == unique(dta$var)[1])$year),
     max = max(subset(dta, var == unique(dta$var)[1])$year),
     value = min(subset(dta, var == unique(dta$var)[1])$year),
     step = 1,
     sep = ''
    )
   ),
  tabPanel("more",
     sliderInput(
       "years_select",
       "Select year range",
       min = min(subset(dta, var == unique(dta$var)[1])$year),
       max = max(subset(dta, var == unique(dta$var)[1])$year),
       value = c(
         min(subset(dta, var == unique(dta$var)[1])$year),
         max(subset(dta, var == unique(dta$var)[1])$year)
       ),
       step = 1,
       sep = ''
     )
  )
)


ui <- fluidPage(

    titlePanel("Dynamic year slider"),

    sidebarLayout(
        sidebarPanel(
            selectInput(
              "var_select", "Select variable",
              choices = unique(dta$var),
              selected = unique(dta$var)[1]
            ),
            selectInput("slider_type", "Select slider type",
                        choices = c("One value" = "one", "Two values" = "more"),
                        selected = "one"

                        ),
        parameter_tabs,
        ),
        mainPanel(
           tableOutput("table_output")
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  current_var <- reactive(input$var_select)
  current_slider_type <- reactive(input$slider_type)
  current_year_value  <- reactive(input$year_select)

  observeEvent(input$var_select, {
    message("The selected var is ", current_var())
    freezeReactiveValue(input, "year_select")
    updateSliderInput(inputId = "year_select",
                      min = min(subset(dta, var == current_var())$year),
                      max = max(subset(dta, var == current_var())$year)

    )
    freezeReactiveValue(input, "years_select")
    updateSliderInput(inputId = "years_select",
                      min = min(subset(dta, var == current_var())$year),
                      max = max(subset(dta, var == current_var())$year)

    )
  })

  observeEvent(input$slider_type, {
    this_slider_type <- current_slider_type()
    message("The current slider type is ", this_slider_type)
      updateTabsetPanel(inputId = "params", selected = this_slider_type)
  })


    output$table_output <- renderTable({
      req(input$year_select)
      req(input$years_select)
      year_years <- switch(current_slider_type(),
        one = input$year_select,
        more = input$years_select[1]:input$years_select[2]
      )
      dta %>%
        filter(var == input$var_select) %>%
        filter(year %in% year_years)
    })
}

# Run the application
shinyApp(ui = ui, server = server)

Answer 2

I'd suggest using two separate sliderInput's wrapped in conditionalPanel's. This UI based solution is faster than a renderUI approach.

library(dplyr)
library(shiny)

dta <- tibble(
  var =
    c(
      rep("A", 10),
      rep("B", 3),
      rep("C", 5)
    ),
  year = c(
    1984:1993,
    1987:1989,
    1990:1994
  )
) %>%
  mutate(
    val = runif(n())
  )

ui <- fluidPage(
  
  titlePanel("Dynamic year slider"),
  
  sidebarLayout(
    sidebarPanel(
      selectInput(
        "var_select", "Select variable",
        choices = unique(dta$var)[1],
        selected = unique(dta$var)[1]
      ),
      selectInput("slider_type", "Select slider type",
                  choices = c("One value" = "one", "Two values" = "more"),
                  selected = "one"
                  
      ),
      conditionalPanel("input.slider_type == 'one'", sliderInput("year_select_regular",
                  "Select year:",
                  min = min(subset(dta, var == unique(dta$var)[1])$year),
                  max = max(subset(dta, var == unique(dta$var)[1])$year),
                  value = min(subset(dta, var == unique(dta$var)[1])$year),
                  step = 1,
                  sep = ''
                  
      )),
      conditionalPanel("input.slider_type == 'more'", sliderInput("year_select_range",
                                                                 "Select year:",
                                                                 min = min(subset(dta, var == unique(dta$var)[1])$year),
                                                                 max = max(subset(dta, var == unique(dta$var)[1])$year),
                                                                 value = c(min(subset(dta, var == unique(dta$var)[1])$year), max(subset(dta, var == unique(dta$var)[1])$year)),
                                                                 step = 1,
                                                                 sep = ''
                                                                 
      ), style = "display:none;")
    ),
    
    mainPanel(
      tableOutput("table_output")
    )
  )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  current_var <- reactive(input$var_select)
  current_slider_type <- reactive(input$slider_type)
  current_year_value  <- reactive(input$year_select)
  
  observeEvent(input$var_select, {
    message("The selected var is ", current_var())
    freezeReactiveValue(input, "year_select")
    updateSliderInput(inputId = "year_select",
                      min = min(subset(dta, var == current_var())$year),
                      max = max(subset(dta, var == current_var())$year)
                      
    )
  })
  
  observeEvent(input$slider_type, {
    this_slider_type <- current_slider_type()
    message("The current slider type is ", this_slider_type)
    if (this_slider_type == "more"){
      message("current_slider_type is more")
      
      updateSliderInput(inputId = "year_select_range",
                        label = "Select years", # this DOES update
                        value = c(1985, 1987) 
                        # Only the first value is passed through in the update
                        #the inclusion of a second value does not change the slider type from one which accepts only a single value, to one which accepts a range
      )
    } else if (this_slider_type == "one"){
      message("current_slider_type is one")
      updateSliderInput(inputId = "year_select_regular",
                        label = "Select year",
                        value = 1986 # this DOES update 
      )
      
    }
    
  })
  
  
  output$table_output <- renderTable({
    req(input$year_select)
    dta %>%
      filter(var == input$var_select) %>%
      filter(year %in% input$year_select)
  })
}

# Run the application
shinyApp(ui = ui, server = server)