Dynamic number of Inputs with ObserveEvents

shiny
1

I am trying to make an app that is completely dynamic so it can be used with future datasets without having to modify any code. I am currently working on creating a page that has a dynamic number of selectizeInputs, each of which needs to be able to filter a dataset. Here is the code I have so far:

#' multi_year UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_multi_year_ui <- function(id) {
  ns <- NS(id)
  tagList(
    div(
      id = "multi-year-page",
      div(
        class = "header",
        span(class = "question-dropdown", selectizeInput(ns("select_question"), "Select a Question", choices = questions_comparison$ID)),
        span(class = "title-section", htmlOutput(ns("title")))
      ),
      div(
        class = "body",
        div(class = "graph-section", plotly::plotlyOutput(ns("multi_year"), height = "100%")),
        div(class = "filter-section", uiOutput(ns("filters")))
      ),
      div(class = "footer")
    )
  )
}

#' multi_year Server Functions
#'
#' @noRd
mod_multi_year_server <- function(id) {
  moduleServer(id, function(input, output, session) {
    ns <- session$ns

    # Create a reactiveValues object to store reactive data
    data <- reactiveValues()

    # Create an observer that listens for changes in the select_question input
    observeEvent(input$select_question, {
      # Get a sorted list of unique years from the data_comparison dataset
      years <- sort(unique(data_comparison$Year))

      # Use lapply to create a list of filtered datasets, one for each year
      data <- lapply(1:length(unique(data_comparison$Year)), function(i) {
        data_comparison %>% dplyr::filter(`Question ID` == input$select_question & Year == years[i])
      })
    })

    rvs <- reactiveValues(filters = list(), observers = list())

    # Loop through each column of the "demographics" data and create a filter for each column.
    rvs$filters <- lapply(names(demographics_comparison), function(column_name) {
      # Extract unique values from the column and remove missing values (NA).
      column_values <- unique(na.omit(demographics_comparison[[column_name]]))

      # If there is one or less unique values in the column, return NULL.
      if (length(column_values) <= 1) {
        return(NULL)
      }

      # If there are less than four unique values in the column, create radio buttons.
      if (length(column_values) < 3) {
        radioButtons(inputId = ns(paste0("filter_", column_name)), label = column_name, choices = c("All", column_values), inline = TRUE)
      } else { # Otherwise, create a selectize input.
        selectizeInput(inputId = ns(paste0("filter_", column_name)), label = column_name, choices = c("All", column_values), width = "100%")
      }
    })

    # Create a list called "observers" in the reactiveValues object "rvs"
    rvs$observers <- lapply(names(demographics_comparison), function(column_name) {
      # Create an observer that listens for changes in the filter input associated with this column
      observeEvent(input[[paste0("filter_", column_name)]], {
        # Print a message indicating that the column has changed
        print(paste0(column_name, " changed!"))
      })
    })


    # Render filters UI
    output$filters <- renderUI({
      rvs$filters
    })

    # The following code renders a UI element that displays the title of the selected question
    output$title <- renderUI({
      # Get the title of the selected question from the questions dataframe
      title <- questions_comparison$Value[questions_comparison$ID == input$select_question]
      # Create an HTML heading element with the title text
      tags$h2(title)
    })

    output$multi_year <- plotly::renderPlotly({
      shinipsum::random_ggplotly()
    })
  })
}

## To be copied in the UI
# mod_multi_year_ui("multi_year_1")

## To be copied in the server
# mod_multi_year_server("multi_year_1")

This somewhat works; it creates the selectizeInputs, renders them and the observeEvents fire when the value for the corresponding input changes, however, the whole point of these inputs is to eventually filter my data using them. When I try to access my data reactiveValues using browser() inside the dynamically created observeEvents, I get this:

Called from: observe()
Browse[1]> data
<ReactiveValues> 
  Values:     
  Readonly:  FALSE

This means that inside the dynamic observeEvent, my data variable is empty. However, if I call browser() inside my observeEvent for when the question is changed, I get:

Called from: observe()
Browse[1]> data
[[1]]
# A tibble: 847 × 15
    Year Gender              Age      Race  Ethni…¹ Lived Living Emplo…² Child Milit…³ Disab…⁴ Income Quest…⁵ Answer Answe…⁶
   <dbl> <chr>               <chr>    <chr> <chr>   <chr> <chr>  <chr>   <chr> <chr>   <chr>   <chr>  <chr>   <chr>    <dbl>
 1  2018 Identify as a woman 35 to 54 Cauc… Non-Hi… More… Rent … Employ… Yes   No      Yes     $25,0… Questi… Good         2
 2  2018 Identify as a man   35 to 54 Cauc… Hispan… More… Own y… Employ… Yes   Yes     No      $150,… Questi… Fair         3
 3  2018 Identify as a woman 35 to 54 Afri… Non-Hi… More… Rent … Retired Yes   No      Yes     Less … Questi… Fair         3
 4  2018 Identify as a woman 35 to 54 Cauc… Non-Hi… More… Own y… Employ… No    Yes     Yes     $25,0… Questi… Good         2
 5  2018 Identify as a woman 35 to 54 Cauc… Non-Hi… More… Own y… Employ… Yes   No      Yes     $50,0… Questi… Fair         3
 6  2018 Identify as a woman 55 and … Cauc… Non-Hi… More… Own y… Retired No    No      No      $50,0… Questi… Good         2
 7  2018 Identify as a woman 55 and … Cauc… Non-Hi… More… Own y… Retired No    No      Yes     NA     Questi… Good         2
 8  2018 Identify as a woman 55 and … Cauc… Non-Hi… More… Own y… NA      No    No      Yes     Less … Questi… Fair         3
 9  2018 Identify as a woman 55 and … NA    Non-Hi… More… Own y… Retired No    Yes     No      NA     Questi… Good         2
10  2018 Identify as a woman 55 and … Cauc… Hispan… More… Own y… Employ… No    No      Yes     Less … Questi… Poor         4
# … with 837 more rows, and abbreviated variable names ¹​Ethnicity, ²​Employment, ³​Military, ⁴​Disabled, ⁵​`Question ID`,
#   ⁶​`Answer Value`
# ℹ Use `print(n = ...)` to see more rows

[[2]]
# A tibble: 989 × 15
    Year Gender              Age      Race  Ethni…¹ Lived Living Emplo…² Child Milit…³ Disab…⁴ Income Quest…⁵ Answer Answe…⁶
   <dbl> <chr>               <chr>    <chr> <chr>   <chr> <chr>  <chr>   <chr> <chr>   <chr>   <chr>  <chr>   <chr>    <dbl>
 1  2022 Identify as a man   55 and … Cauc… Non-Hi… More… Own y… Employ… No    No      No      $100,… Questi… Excel…       1
 2  2022 Identify as a man   55 and … Cauc… Non-Hi… More… Own y… Retired No    Yes     No      $25,0… Questi… Good         2
 3  2022 Identify as a woman 55 and … Amer… Non-Hi… More… Rent … Retired No    No      Yes     $25,0… Questi… Good         2
 4  2022 Identify as a man   18 to 34 Cauc… Non-Hi… 1 to… Other… Employ… No    No      No      $50,0… Questi… Excel…       1
 5  2022 Identify as a man   55 and … Cauc… Non-Hi… More… Own y… Retired No    No      Yes     $50,0… Questi… Good         2
 6  2022 Identify as a man   55 and … Cauc… Non-Hi… More… Own y… Retired No    No      Yes     Less … Questi… Good         2
 7  2022 Identify as a woman 55 and … Cauc… Non-Hi… More… Own y… Employ… No    No      No      $50,0… Questi… Good         2
 8  2022 Identify as a woman 35 to 54 Afri… Non-Hi… More… Rent … Employ… No    No      No      $50,0… Questi… Good         2
 9  2022 Identify as a man   55 and … Cauc… Non-Hi… More… Own y… Retired Yes   Yes     No      $50,0… Questi… Excel…       1
10  2022 Identify as a woman 35 to 54 Cauc… Non-Hi… 1 to… Own y… Unempl… No    No      No      $50,0… Questi… Good         2
# … with 979 more rows, and abbreviated variable names ¹​Ethnicity, ²​Employment, ³​Military, ⁴​Disabled, ⁵​`Question ID`,
#   ⁶​`Answer Value`
# ℹ Use `print(n = ...)` to see more rows

Can anyone explain why the data would be empty inside the dynamically created observeEvent? The data is updated/initialized as soon as the app is loaded and the dynamic selectInputs and associated observeEvents are created only when I switch to the tab containing them, so I don't believe it is a matter of them being created before data is updated.

Also, if there is a better way to create these inputs with observers that does not require any button press, I would definitely be willing to try a different way. I do not want to use action buttons at all for this, I want the data to update whenever a filter is changed so the graph shows the change immediately.

2

I've made a few improvements to your code.

Firstly, I've created some mock data so my code is reproducible. Obviously it's not as complicated as your data, but hopefully I've understood the purpose of the three datasets.

Secondly, I moved the generation of your filters UI (which was initially generated using renderUI() on the server side) into the mod_multi_year_ui() function. While you are repeatedly generating UI, this UI is technically static (meaning it does not need to be rendered on the server side) because the demographics_comparison dataset also seems to be static. If this dataset will change when the site is active (e.g. the user can add questions) then the problem will become much more complex.

In terms of reacting to these inputs (to apply the filters), you can do this using just one observer, rather than creating multiple. You can use this to apply the filters to the data (I'm not quite sure what you want to do there, so I've left it).

Finally, I've added a small optimisation by using a textOutput() instead of a htmlOutput() for your title.

library(shiny)
library(shinydashboard)
library(magrittr)

# Probably very oversimplified
data_comparison <- tibble::tribble(
  ~`Question ID`, ~Year, ~demographic_x, ~demographic_y,
  1, 2001, 1, "a",
  1, 2001, 2, "a",
  1, 2002, 3, "a",
  2, 2002, 4, "b",
  2, 2003, 5, "b"
)

questions_comparison <- tibble::tribble(
  ~ID, ~Value,
  1, "Q1",
  2, "Q2",
  3, "Q3",
  4, "Q4"
)

demographics_comparison <- tibble::tribble(
  ~demographic_x, ~demographic_y,
  1, "a",
  2, "a",
  3, "a",
  4, "b",
  5, "b"
)

#' multi_year UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_multi_year_ui <- function(id) {
  ns <- NS(id)
  
  # Loop through each column of the "demographics" data and create a filter for each column.
  
  # We don't actually need to generate this server side since it is technically
  # static (provided that the demographics_comparison dataset is not reactive).
  filters_ui <- lapply(names(demographics_comparison), function(column_name) {
    # Extract unique values from the column and remove missing values (NA).
    column_values <- unique(na.omit(demographics_comparison[[column_name]]))
    
    # If there is one or less unique values in the column, return NULL.
    if (length(column_values) <= 1) {
      return(NULL)
    }
    
    # If there are less than four unique values in the column, create radio buttons.
    if (length(column_values) < 3) {
      radioButtons(inputId = ns(paste0("filter_", column_name)), label = column_name, choices = c("All", column_values), inline = TRUE)
    } else { # Otherwise, create a selectize input.
      selectizeInput(inputId = ns(paste0("filter_", column_name)), label = column_name, choices = c("All", column_values), width = "100%")
    }
  })
  
  tagList(
    div(
      id = "multi-year-page",
      div(
        class = "header",
        span(class = "question-dropdown", selectizeInput(ns("select_question"), "Select a Question", choices = questions_comparison$ID)),
        # We can use a textOutput instead of a HTML output for more efficiency here
        span(class = "title-section", textOutput(ns("title"), container = tags$h2))
      ),
      div(
        class = "body",
        div(class = "graph-section", plotly::plotlyOutput(ns("multi_year"), height = "100%")),
        div(class = "filter-section", filters_ui)
      ),
      div(class = "footer")
    )
  )
}

#' multi_year Server Functions
#'
#' @noRd
mod_multi_year_server <- function(id) {
  moduleServer(id, function(input, output, session) {
    # When you want to return a value from an observer, use a reactive instead
    data <- eventReactive(input$select_question, {
      # Get a sorted list of unique years from the data_comparison dataset
      years <- sort(unique(data_comparison$Year))
      
      # Use lapply to create a list of filtered datasets, one for each year
      data <- lapply(1:length(unique(data_comparison$Year)), function(i) {
        data_comparison %>% dplyr::filter(`Question ID` == input$select_question & Year == years[i])
      })
    })
    
    # We could use observe() instead but it's nice to be explicit as to
    # what we are depending on
    observeEvent({
      list(
        data(),
        lapply(names(demographics_comparison), function(colname) {
          input[[paste0("filter_", colname)]]
        })
      )
    }, {
      # Here we can do whatever we want with the data and the filters
      # This will update whenever the data or any of the filters change
      print(data())
      
      filters <- lapply(names(demographics_comparison), function(colname) {
        input[[paste0("filter_", colname)]]
      })
      print(filters)
    })
    
    # The following code renders a UI element that displays the title of the selected question
    output$title <- reactive({
      # Get the title of the selected question from the questions dataframe
      questions_comparison$Value[questions_comparison$ID == input$select_question]
    })
    
    output$multi_year <- plotly::renderPlotly({
      shinipsum::random_ggplotly()
    })
  })
}
3

This topic was automatically closed 54 days after the last reply. New replies are no longer allowed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.