How to make selectInput choices reactive?-CodePudding

In my code I use two selectInput() functions: one for the indicating the start period to feed into a custom function, and another for indicating the end period to feed into the same custom function. At the bottom is a simplified MWE extract of the code, which doesn't use this custom function, using instead rbind() to join and output the to/from data for sake of simplicity. In the full code, the end period must always be greater than (>) the start period for the custom function to work.

How would I make the choices in the "To" (selectInput(inputId = "toPeriod"...) reflect only those values > than what was input by the user in the "From" (selectInput(inputId = "fromPeriod") function?

I realize this requires making the to/from input choices reactive, so I started by moving the selectInput() functions into the server section using renderUI, but I stopped when receiving the message "Warning: Error in : Problem with filter() input ..1." even though the output is correct. In any case, both before and after moving the selectInput() functions into the server section, this code seems to run slowly.

This image better explains:

There are other posts getting at the same issue but either the code examples are overly-cumbersome or the questions/answers are poorly written or explained: R Shiny selectInput Reactivity, R shiny passing reactive to selectInput choices, Vary the choices in selectinput based on other conditions in shiny R, etc.

MWE code:

library(dplyr)
library(shiny)
library(tidyverse)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9)
  )

ui <- fluidPage(
  tableOutput("data"),
  uiOutput("fromPeriod"),
  uiOutput("toPeriod"),
  tableOutput("dataSelect")
)

server <- function(input, output) {
  
  output$fromPeriod <- renderUI({
    selectInput(inputId = "fromPeriod",label = "From period:",choices = unique(data$Period), selected = 1)
  })
  
  output$toPeriod <- renderUI({
    selectInput(inputId = "toPeriod",label = "To period:",choices = unique(data$Period), selected = 2)
  })
  
  output$data <- renderTable({data})
  
  output$dataSelect <- renderTable({
    part1 <- data %>% filter(Period == input$fromPeriod)
    part2 <- data %>% filter(Period == input$toPeriod)
    rbind(part1,part2)
  }, rownames = TRUE)
}

shinyApp(ui, server)

CodePudding user response：

You should avoid renderUI where possible and use update* functions instead - updating is faster than re-rendering:

library(shiny)
library(data.table)

DT <- data.table(
  ID = c(1, 1, 1, 2, 2, 2, 3, 3, 3),
  Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
  Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9)
)

all_choices <- unique(DT$Period)

ui <- fluidPage(
  tableOutput("data"),
  selectizeInput(
    inputId = "fromPeriod",
    label = "From period:",
    choices = setdiff(all_choices, last(all_choices)),
    selected = 1
  ),
  selectizeInput(
    inputId = "toPeriod",
    label = "To period:",
    choices = setdiff(all_choices, first(all_choices)),
    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[all_choices > input$fromPeriod],
      selected = max(all_choices[all_choices > input$fromPeriod])
    )
  }, ignoreInit = TRUE)
  
  output$dataSelect <- renderTable({
    # in one line, however you seem to need part1 / part2 for your custom function
    # setorder(DT[Period %in% c(input$fromPeriod, input$toPeriod)], Period)
    part1 <- DT[Period == input$fromPeriod]
    part2 <- DT[Period == input$toPeriod]
    rbindlist(list(part1, part2))
  }, rownames = TRUE)
}

shinyApp(ui, server)

To avoid triggering reactives or outputs unnecessarily you should almost alway use freezeReactiveValue when using a update* function in shiny. Please see this related chapter from Mastering Shiny.

CodePudding user response：

Thanks for the clear question and great minimal example.

You receive the warning "Warning: Error in : Problem with filter() input ..1." because on loading the first time, initially the fromPeriod and toPeriod are NULL. They are loaded right thereafter, so you can see the results just fine. You can prevent the warning by adding req(input$fromPeriod) to the renderTable({...}) body.

The SelectInput can be updated using updateSelectInput. We need to wrap this in an observe statement such that it reacts to changes in input$fromPeriod. I created a variable all_choices in the beginning of the server body to make the code a bit more readable.

library(dplyr)
library(shiny)
library(tidyverse)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9)
  )

ui <- fluidPage(
  tableOutput("data"),
  uiOutput("fromPeriod"),
  uiOutput("toPeriod"),
  tableOutput("dataSelect")
)

server <- function(input, output, session) {
  all_choices <- unique(data$Period)
  
  output$fromPeriod <- renderUI({
    selectInput(inputId = "fromPeriod", label = "From period:", choices = unique(data$Period), selected = 1)
  })
  
  output$toPeriod <- renderUI({
    selectInput(inputId = "toPeriod", label = "To period:",choices = unique(data$Period), selected = 2)
  })
  
  observe({
    req(input$fromPeriod)
    
    new_choices <- all_choices[all_choices > as.numeric(input$fromPeriod)]
    updateSelectInput(session, inputId = "toPeriod", choices = new_choices, selected = min(new_choices))
  })
  
  output$data <- renderTable({data})
  
  output$dataSelect <- renderTable({
    req(input$fromPeriod)
    part1 <- data %>% filter(Period == input$fromPeriod)
    part2 <- data %>% filter(Period == input$toPeriod)
    rbind(part1,part2)
  }, rownames = TRUE)
}

shinyApp(ui, server)