rshinyshiny-reactivityrenderui

How to make selectizeInput function reactive to multiple user inputs?

This post is a follow-on to yesterday's post, How to make selectInput choices reactive?.

The data frame shown at the top of the image below and generated via the MWE at the bottom of this post has two types of period measurements: Period_1 and Period_2. Period_1 represents the number of months elapsed since the element arose, and Period_2 is a calendar month representation in YYYY-MM form. I inserted a radioButton() giving the user the choice of which period type ("periodType") to run through the simple placeholder function in the server section, but am unsure of an efficient way to do this, especially in the selectizeInput() functions currently in the ui section, without resorting to renderUI(). Any suggestions for how to do this?

This image better explains:

enter image description here

MWE code:

library(shiny)
library(data.table)

DT <- data.table(
  ID = c(1, 1, 1, 2, 2, 2, 3, 3, 3),
  Period_1 = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
  Period_2 = c("2020-01","2020-02","2020-03","2020-02","2020-03","2020-04","2020-03","2020-04","2020-05"),
  Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9)
)

all_choices <- function(x) {unique(x)}

ui <- fluidPage(
  tableOutput("data"),
  
  radioButtons("periodType",
               label = "Period type selection:",
               choiceNames = c('Period_1','Period_2'),
               choiceValues = c('Period_1','Period_2'),
               selected = 'Period_1',
               inline = TRUE
  ),
  
  selectizeInput(
    inputId = "fromPeriod",
    label = "From period:",
    choices = setdiff(all_choices(DT$Period_1), last(all_choices(DT$Period_1))),
    selected = 1
  ),
  selectizeInput(
    inputId = "toPeriod",
    label = "To period:",
    choices = setdiff(all_choices(DT$Period_1), first(all_choices(DT$Period_1))),
    selected = 2
  ),
  tableOutput("dataSelect")
)

server <- function(input, output, session) {
  
  output$data <- renderTable({DT})
  
  observeEvent(input$fromPeriod, {
    freezeReactiveValue(input, "toPeriod")
    updateSelectizeInput(
      session,
      inputId = "toPeriod",
      choices = all_choices(DT$Period_1)[all_choices(DT$Period_1) > input$fromPeriod],
      selected = max(all_choices(DT$Period_1)[all_choices(DT$Period_1) > input$fromPeriod])
    )
  }, ignoreInit = TRUE)
  
  output$dataSelect <- renderTable({
    setorder(DT[Period_1 %in% c(input$fromPeriod, input$toPeriod)], Period_1)
  }, rownames = TRUE)
}

shinyApp(ui, server)
Solution

  • We can update the choices based on the selection:

    library(shiny)
library(data.table)

DT <- data.table(
  ID = c(1, 1, 1, 2, 2, 2, 3, 3, 3),
  Period_1 = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
  Period_2 = c("2020-01","2020-02","2020-03","2020-02","2020-03","2020-04","2020-03","2020-04","2020-05"),
  Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9)
)

all_choices_p1 <- unique(DT$Period_1)
all_choices_p2 <- unique(DT$Period_2)

ui <- fluidPage(
  tableOutput("data"),
  radioButtons("periodType",
               label = "Period type selection:",
               choiceNames = c('Period_1','Period_2'),
               choiceValues = c('Period_1','Period_2'),
               selected = 'Period_1',
               inline = TRUE
  ),
  selectizeInput(
    inputId = "fromPeriod",
    label = "From period:",
    choices = all_choices_p1[-length(all_choices_p1)],
    selected = 1
  ),
  selectizeInput(
    inputId = "toPeriod",
    label = "To period:",
    choices = all_choices_p1[-1],
    selected = 2
  ),
  tableOutput("dataSelect")
)

server <- function(input, output, session) {
  
  all_choices_reactive <- reactiveVal(all_choices_p1)
  output$data <- renderTable({DT})
  
  observeEvent(input$periodType, {
    if(input$periodType == "Period_1"){
      all_choices_reactive(all_choices_p1)
    } else {
      all_choices_reactive(all_choices_p2)
    }
    updateSelectizeInput(
      session,
      inputId = "fromPeriod",
      choices = all_choices_reactive()[-length(all_choices_reactive())]
    )
    updateSelectizeInput(
      session,
      inputId = "toPeriod",
      choices = all_choices_reactive()[-1]
    )
  })
  
  observeEvent(input$fromPeriod, {
    freezeReactiveValue(input, "toPeriod")
    updateSelectizeInput(
      session,
      inputId = "toPeriod",
      choices = all_choices_reactive()[all_choices_reactive() > input$fromPeriod],
      selected = max(all_choices_reactive()[all_choices_reactive() > input$fromPeriod])
    )
  }, ignoreInit = TRUE)
  
  output$dataSelect <- renderTable({
    if(input$periodType == "Period_1"){
      keep_cols <- c("ID", "Period_1", "Values")
      setorder(DT[Period_1 %in% c(input$fromPeriod, input$toPeriod), ..keep_cols], Period_1)
    } else {
      keep_cols <- c("ID", "Period_2", "Values")
      setorder(DT[Period_2 %in% c(input$fromPeriod, input$toPeriod), ..keep_cols], Period_2)
    }
  }, rownames = TRUE)
}

shinyApp(ui, server)