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)

CodePudding user response：

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)

CodePudding user response：

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)