Advanced shiny help: dropdown depends on another dropdown, trigger reactivity when both had a chance to update

[dean8jackson]

I have a shiny app with two dropdown inputs. The values in the second dropdown depend on the selection in the first one. The straight-forward implementation causes a reactive to trigger twice: once for the first dropdown changing, and again when the second dropdown gets its choices updated. I'm looking for a clean solution to fix this, so that only one reactive trigger will happen, without writing hacky code.

As an example, here's a base code that works:

library(shiny)
library(dplyr)

fulldf <- data.frame(
  country = c(rep("A", 6), rep("B", 6)),
  gender = rep(c("M", "F"), 6),
  age = rep(c("baby", "child", "adult"), 4),
  value = c(10, 40, 100, 8, 50, 75, 9, 39, 99, 7, 49, 74)
)

ui <- fluidPage(
  fluidRow(
    column(4, selectInput("country", "Country", sort(unique(fulldf$country)))),
    column(4, selectInput("subgroup_var", "Subgroup variable", c("None", "gender", "age"))),
    column(4, selectInput("subgroup_value", "Subgroup value", NULL))
  ),
  tableOutput("results")
)

server <- function(input, output, session) {
  
  observeEvent(input$subgroup_var, {
    if (input$subgroup_var == "None") {
      choices <- c("")
    } else {
      choices <- fulldf %>% pull(input$subgroup_var) %>% unique()
    }
    updateSelectInput(session, "subgroup_value", choices = choices)
  })
  
  filtered_data <- reactive({
    message("calculating data")
    data <- fulldf %>% filter(country == input$country)
    if (input$subgroup_var != "None") {
      data <- data %>% filter(!!sym(input$subgroup_var) == input$subgroup_value)
    }
    data
  })
  
  output$results <- renderTable({
    message("rendering table")
    filtered_data()
  })
  
}

shinyApp(ui, server)

The problem is that the table is rendered twice. One simple "fix" would be to simply isolate the first dropdown from the filtering, but that doesn't necessarily always result in the correct behaviour.

What would be the best way to fix this code?

[ismirsehregal]

Edit:

I just had a better idea: we can use bindEvent to restrict your reactive filtered_data to only listen on changes to your downstream input$subgroup_value:

library(shiny)
library(dplyr)

fulldf <- data.frame(
  country = c(rep("A", 6), rep("B", 6)),
  gender = rep(c("M", "F"), 6),
  age = rep(c("baby", "child", "adult"), 4),
  value = c(10, 40, 100, 8, 50, 75, 9, 39, 99, 7, 49, 74)
)

ui <- fluidPage(
  fluidRow(
    column(4, selectInput("country", "Country", sort(unique(fulldf$country)))),
    column(4, selectInput("subgroup_var", "Subgroup variable", c("None", "gender", "age"))),
    column(4, selectInput("subgroup_value", "Subgroup value", NULL))
  ),
  tableOutput("results")
)

server <- function(input, output, session) {
  
  observeEvent(input$subgroup_var, {
    if (input$subgroup_var == "None") {
      choices <- c("")
    } else {
      choices <- fulldf %>% pull(input$subgroup_var) %>% unique()
    }
    updateSelectInput(session, "subgroup_value", choices = choices)
  })
  
  filtered_data <- reactive({
    message("calculating data")
    data <- fulldf %>% filter(country == input$country)
    if (input$subgroup_var != "None") {
      data <- data %>% filter(!!sym(input$subgroup_var) == input$subgroup_value)
    }
    data
  }) |> bindEvent(input$subgroup_value)
  
  output$results <- renderTable({
    message("rendering table")
    filtered_data()
  })
  
}

shinyApp(ui, server)

To avoid rendering the table twice, we can debounce the filtered dataset. The calculation is still triggered twice - however, I guess avoiding a flickering table is the most important part.

library(shiny)
library(dplyr)

fulldf <- data.frame(
  country = c(rep("A", 6), rep("B", 6)),
  gender = rep(c("M", "F"), 6),
  age = rep(c("baby", "child", "adult"), 4),
  value = c(10, 40, 100, 8, 50, 75, 9, 39, 99, 7, 49, 74)
)

ui <- fluidPage(
  fluidRow(
    column(4, selectInput("country", "Country", sort(unique(fulldf$country)))),
    column(4, selectInput("subgroup_var", "Subgroup variable", c("None", "gender", "age"))),
    column(4, selectInput("subgroup_value", "Subgroup value", NULL))
  ),
  tableOutput("results")
)

server <- function(input, output, session) {
  
  observeEvent(input$subgroup_var, {
    if (input$subgroup_var == "None") {
      choices <- c("")
    } else {
      choices <- fulldf %>% pull(input$subgroup_var) %>% unique()
    }
    updateSelectInput(session, "subgroup_value", choices = choices)
  })
  
  filtered_data <- reactive({
    message("calculating data")
    data <- fulldf %>% filter(country == input$country)
    if (input$subgroup_var != "None") {
      data <- data %>% filter(!!sym(input$subgroup_var) == input$subgroup_value)
    }
    data
  })
  
  debounced_data <- debounce(filtered_data, 300L)
  
  output$results <- renderTable({
    message("rendering table")
    debounced_data()
  })
  
}

shinyApp(ui, server)

PS: also check ?bindCache

[ismirsehregal]

Please don't delete the question - it might be useful to future readers.

[nirgrahamuk]

I would consider gathering all the inputs together in a list within a reactive, and debouncing that.

library(shiny)
library(dplyr)

fulldf <- data.frame(
  country = c(rep("A", 6), rep("B", 6)),
  gender = rep(c("M", "F"), 6),
  age = rep(c("baby", "child", "adult"), 4),
  value = c(10, 40, 100, 8, 50, 75, 9, 39, 99, 7, 49, 74)
)

ui <- fluidPage(
  fluidRow(
    column(4, selectInput("country", "Country", sort(unique(fulldf$country)))),
    column(4, selectInput("subgroup_var", "Subgroup variable", c("None", "gender", "age"))),
    column(4, selectInput("subgroup_value", "Subgroup value", NULL))
  ),
  tableOutput("results")
)

server <- function(input, output, session) {
  
  observeEvent(input$subgroup_var, {
    if (input$subgroup_var == "None") {
      choices <- c("")
    } else {
      choices <- fulldf %>% pull(input$subgroup_var) %>% unique()
    }
    updateSelectInput(session, "subgroup_value", choices = choices)
  })
  
  key_inputs <- reactive({list(ic=  input$country,
                          isvar = input$subgroup_var,
                          isval = input$subgroup_value)}) |> debounce(50)
  
  filtered_data <- reactive({
    ki <- req(key_inputs())
    message("calculating data")
    data <- fulldf %>% filter(country == ki$ic)
    if (ki$isvar != "None") {
      data <- data %>% filter(!!sym(ki$isvar) == ki$isval)
    }
    data
  })
  
  output$results <- renderTable({
    message("rendering table")
    filtered_data()
  })
  
}

shinyApp(ui, server)