Dynamic UI for successive filtering of data

Question

I have been reading and watching videos on Shiny Modules. I am trying to implement it one of my apps and am running into some trouble. I have extensively look at several questions here and examples but I am still unable to fix the error.

What I am trying to achieve is to dynamically add filters. I read in a dataframe when I load the app. I then want to add/remove filters dynamically using an "Add-Filter" button, which brings up a selectInput box that allows the user to choose any variable in the dataframe. Once this is chosen, I want the app to open a checkbox UI where the checkboxes are factor levels of that variable. I am able to add the selectInput box but am having trouble with the dynamic checkboxes. I have borrowed a lot of code from one of Jonas Hagenberg's examples.

Below is a reprex:

library(shiny)
library(ggplot2)

`%nin%` <- Negate(`%in%`)

cell_type <- sample( 
  c("BCell", "TCell", "Marcophage", "Monocyte"),
  100, replace = TRUE) %>% as.factor
sex <- sample( 
  c("Male", "Female"),
  100, replace = TRUE) %>% as.factor
disease <- sample( 
  c("adenocarcinoma", "copd", "nsclc", "sclc"),
  100, replace = TRUE) %>% as.factor
tumor <- sample( 
  c("tumor", "normal", "early"),
  100, replace = TRUE) %>% as.factor
exp = sample(
  c(1:2000), replace = FALSE
)

df <- data.frame( cell_type, sex, disease, tumor, exp )

#var_choices <- setdiff(names(df), "exp") %>% as.list
#names(var_choices) = var_choices
varChoices <- setdiff(names(df), "exp")

var_ui <- function(id) {
  ns <- NS(id)
  # Update var_choices by removing existing selections
  var_choices <- varChoices
  div(
    id = id,
    selectInput(
      inputId = ns("var_choice"),
      label = "variable to subset",
      choices = c(var_choices)
    ),
    uiOutput(
      outputId = ns("selected_var")
    )
  )
}

var_server <- function(id, df) {
  moduleServer(
    id,
    function(input, output, session) {
      #browser()
      vals <- reactive({ levels( df[[ input$var_choice ]] ) })
      output$selected_var <- renderUI({
        ns <- session$ns
        # update based on selected_var
        # vals = c("BCell", "TCell", "Monocyte", "Macrophage")
        checkboxGroupInput(
          inputId = ns("val_choice"),
          label = "Select which cells to show", 
          inline = TRUE,
          choices = vals, 
          selected = vals
        )
        #return(reactive({input$var_choice}))
      })
    }
  )
}


ui <- fluidPage(
  h5(""),
  actionButton(
    inputId = "add_module",
    label = "Add a module"
  ),
  actionButton(
    inputId = "remove_module",
    label = "Remove a module"
  )
)


server <- function(input, output, session) {
  
  active_modules <- reactiveVal(value = NULL)
  
  observeEvent(input$add_module, {
    # update the list of currently shown modules
    current_id <- paste0("id_", input$add_module)
    active_modules(c(current_id, active_modules()))
    
    var_server(
      id = current_id,
      df = df
    )
    
    insertUI(
      selector = "h5",
      where = "beforeEnd",
      ui = var_ui(id = current_id)
    )
  })
  
  observeEvent(input$remove_module, {
    
    # only remove a module if there is at least one module shown
    if (length(active_modules()) > 0) {
      current_id <- active_modules()[1]
      removeUI(
        selector = paste0("#", current_id)
      )
      
      # update the list of currently shown modules
      active_modules(active_modules()[-1])
    }
  })
}


shinyApp(ui, server)

What am I missing ?

Thanks -JJ

I get the selectInputUI added dynamically, but the checkboxUI is not created dynamically.

Answer 1

Try this

library(shiny)
library(ggplot2)
library(tidyverse)

`%nin%` <- Negate(`%in%`)

cell_type <- sample( 
  c("BCell", "TCell", "Marcophage", "Monocyte"),
  100, replace = TRUE) %>% as.factor
sex <- sample( 
  c("Male", "Female"),
  100, replace = TRUE) %>% as.factor
disease <- sample( 
  c("adenocarcinoma", "copd", "nsclc", "sclc"),
  100, replace = TRUE) %>% as.factor
tumor <- sample( 
  c("tumor", "normal", "early"),
  100, replace = TRUE) %>% as.factor
exp = sample(
  c(1:2000), replace = FALSE
)

df <- data.frame( cell_type, sex, disease, tumor, exp )

#var_choices <- setdiff(names(df), "exp") %>% as.list
#names(var_choices) = var_choices
varChoices <- setdiff(names(df), "exp")

var_ui <- function(id) {
  ns <- NS(id)
  # Update var_choices by removing existing selections
  #var_choices <- varChoices
  div(
    id = id,
    selectInput(
      inputId = ns("var_choice"),
      label = "variable to subset",
      choices = varChoices
    ),
    uiOutput(
      outputId = ns("selected_var")
    )
  )
}

var_server <- function(id, df) {
  moduleServer(
    id,
    function(input, output, session) {
      ns <- session$ns
      vals <- reactive({ df[[ input$var_choice ]] %>% levels() })
      
      output$selected_var <- renderUI({
        # print(input$var_choice)
        # update based on selected_var
        
        checkboxGroupInput(
          inputId = ns("val_choice"),
          label = "Select which cells to show", 
          inline = TRUE,
          choices = vals(), 
          selected = vals()
        )
        #return(reactive({input$var_choice}))
      })
    }
  )
}


ui <- fluidPage(
  actionButton(
    inputId = "add_module",
    label = "Add a module"
  ),
  actionButton(
    inputId = "remove_module",
    label = "Remove a module"
  ),
  div(
    id = "add_here"
  )
)


server <- function(input, output, session) {
  
  active_modules <- reactiveVal(value = NULL)
  
  observeEvent(input$add_module, {
    # update the list of currently shown modules
    current_id <- paste0("id_", input$add_module)
    active_modules(c(current_id, active_modules()))
    
    var_server(id = current_id, df)
    
    insertUI(
      selector = "#add_here",
      where = "beforeEnd",
      ui = var_ui(id = current_id)
    )
  })
  
  observeEvent(input$remove_module, {
    
    # only remove a module if there is at least one module shown
    if (length(active_modules()) > 0) {
      current_id <- active_modules()[1]
      removeUI(
        selector = paste0("#", current_id)
      )
      
      # update the list of currently shown modules
      active_modules(active_modules()[-1])
    }
  })
}


shinyApp(ui, server)