R Shiny: How to dynamically append arbitrary number of input widgets

Question

The goal

I am working on a Shiny app that allows the user to upload their own data and focus on the entire data or a subset by providing data filtering widgets describ

Answer 1

If you are looking for a data subsetting/filtering in Shiny Module :

filterData from package shinytools can do the work. It returns an expression as a call but it can also return the data (if your dataset is not too big).

library(shiny)
# remotes::install_github("ardata-fr/shinytools")
library(shinytools)

ui <- fluidPage(
  fluidRow(
    column(
      3,
      filterDataUI(id = "ex"),
      actionButton("AB", label = "Apply filters")
    ),
    column(
      3,
      tags$strong("Expression"),
      verbatimTextOutput("expression"),
      tags$br(),
      DT::dataTableOutput("DT")
    )
  )
)

server <- function(input, output) {

  x <- reactive({iris})

  res <- callModule(module = filterDataServer, id = "ex", x = x, return_data = FALSE)

  output$expression <- renderPrint({
    print(res$expr)
  })

  output$DT <- DT::renderDataTable({
    datatable(data_filtered())
  })

  data_filtered <- eventReactive(input$AB, {
    filters <- eval(expr = res$expr, envir = x())
    x()[filters,]

  })
}

shinyApp(ui, server)

You can also use lazyeval or rlang to evaluate the expression :

filters <- lazyeval::lazy_eval(res$expr, data = x())
filters <- rlang::eval_tidy(res$expr, data = x())

Answer 2

are you looking for something like this?

library(shiny)


LHSchoices <- c("X1", "X2", "X3", "X4")


#------------------------------------------------------------------------------#

# MODULE UI ----
variablesUI <- function(id, number) {

  ns <- NS(id)

  tagList(
    fluidRow(
      column(6,
             selectInput(ns("variable"),
                         paste0("Select Variable ", number),
                         choices = c("Choose" = "", LHSchoices)
             )
      ),

      column(6,
             numericInput(ns("value.variable"),
                          label = paste0("Value ", number),
                          value = 0, min = 0
             )
      )
    )
  )

}

#------------------------------------------------------------------------------#

# MODULE SERVER ----

variables <- function(input, output, session, variable.number){
  reactive({

    req(input$variable, input$value.variable)

    # Create Pair: variable and its value
    df <- data.frame(
      "variable.number" = variable.number,
      "variable" = input$variable,
      "value" = input$value.variable,
      stringsAsFactors = FALSE
    )

    return(df)

  })
}

#------------------------------------------------------------------------------#

# Shiny UI ----

ui <- fixedPage(
  verbatimTextOutput("test1"),
  tableOutput("test2"),
  variablesUI("var1", 1),
  h5(""),
  actionButton("insertBtn", "Add another line")

)

# Shiny Server ----

server <- function(input, output) {

  add.variable <- reactiveValues()

  add.variable$df <- data.frame("variable.number" = numeric(0),
                                "variable" = character(0),
                                "value" = numeric(0),
                                stringsAsFactors = FALSE)

  var1 <- callModule(variables, paste0("var", 1), 1)

  observe(add.variable$df[1, ] <- var1())

  observeEvent(input$insertBtn, {

    btn <- sum(input$insertBtn, 1)

    insertUI(
      selector = "h5",
      where = "beforeEnd",
      ui = tagList(
        variablesUI(paste0("var", btn), btn)
      )
    )

    newline <- callModule(variables, paste0("var", btn), btn)

    observeEvent(newline(), {
      add.variable$df[btn, ] <- newline()
    })

  })

  output$test1 <- renderPrint({
    print(add.variable$df)
  })

  output$test2 <- renderTable({
    add.variable$df
  })

}

#------------------------------------------------------------------------------#

shinyApp(ui, server)

Answer 3

You need to check for existing input values and use them if available:

  # Prevent dynamic inputs from resetting
  newInputValue <- "Option 1"
  if (newInputId %in% names(input)) {
    newInputValue <- input[[newInputId]]
  }
  # Define new input
  newInput <- selectInput(newInputId, newInputLabel, c("Option 1", "Option 2", "Option 3"), selected=newInputValue)

A working version of the gist (without the reset problem) can be found here: https://gist.github.com/motin/0d0ed0d98fb423dbcb95c2760cda3a30

Copied below:

ui.R

library(shiny)

shinyUI(pageWithSidebar(

  # Application title
  headerPanel("Dynamically append arbitrary number of inputs"),

  # Sidebar with a slider input for number of bins
  sidebarPanel(
    uiOutput("allInputs"),
    actionButton("appendInput", "Append Input")
  ),

  # Show a plot of the generated distribution
  mainPanel(
    p("This shows how to add an arbitrary number of inputs
      without resetting the values of existing inputs each time a new input is added.
      For example, add a new input, set the new input's value to Option 2, then add
      another input. Note that the value of the first input does not reset to Option 1.")
  )
))

server.R

library(shiny)

shinyServer(function(input, output) {

  output$allInputs <- renderUI({
    # Get value of button, which represents number of times pressed (i.e. number of inputs added)
    inputsToShow <- input$appendInput
    # Return if button not pressed yet
    if(is.null(inputsToShow) || inputsToShow < 1) return()
    # Initialize list of inputs
    inputTagList <- tagList()
    # Populate the list of inputs
    lapply(1:inputsToShow,function(i){
      # Define unique input id and label
      newInputId <- paste0("input", i)
      newInputLabel <- paste("Input", i)
      # Prevent dynamic inputs from resetting
      newInputValue <- "Option 1"
      if (newInputId %in% names(input)) {
        newInputValue <- input[[newInputId]]
      }
      # Define new input
      newInput <- selectInput(newInputId, newInputLabel, c("Option 1", "Option 2", "Option 3"), selected=newInputValue)
      # Append new input to list of existing inputs
      inputTagList <<- tagAppendChild(inputTagList, newInput)
    })
    # Return updated list of inputs
    inputTagList
  })

})

(The solution was guided on Nick's hints in the original gist from where you got the code of the promising solution)

Answer 4

Now, I think that I understand better the problem.

Suppose the user selects the datasets::airquality dataset (here, I'm showing only the first 10 rows):

The field 'Select Variable 1' shows all the possible variables based on the column names of said dataset:

Then, the user selects the condition and the value to filter the dataset by:

Then, we want to add a second filter (still maintaining the first one):

Finally, we get the dataset filtered by the two conditions:

If we want to add a third filter:

You can keep adding filters until you run out of data.

You can also change the conditions to accommodate factors or character variables. All you need to do is change the selectInput and numericInput to whatever you want.

If this is what you want, I've solved it using modules and by creating a reactiveValue (tmpFilters) that contains all selections (variable + condition + value). From it, I created a list with all filters (tmpList) and from it I created the proper filter (tmpListFilters) to use with subset.

This works because the final dataset is "constantly" being subset by this reactiveValue (the tmpFilters). At the beginning, tmpFilters is empty, so we get the original dataset. Whenever the user adds the first filter (and other filters after that), this reactiveValue gets updated and so does the dataset.

Here's the code for it:

library(shiny)

# > MODULE #####################################################################

## |__ MODULE UI ===============================================================

variablesUI <- function(id, number, LHSchoices) {
  
  ns <- NS(id)
  
  tagList(
    fluidRow(
      column(
        width = 4,
        selectInput(
          inputId = ns("variable"),
          label   = paste0("Select Variable ", number),
          choices = c("Choose" = "", LHSchoices)
        )
      ),
      
      column(
        width = 4,
        selectInput(
          inputId = ns("condition"),
          label   = paste0("Select condition ", number),
          choices = c("Choose" = "", c("==", "!=", ">", ">=", "<", "<="))
        )
      ),
      
      column(
        width = 4,
        numericInput(
          inputId = ns("value.variable"),
          label   = paste0("Value ", number),
          value   = NA, 
          min     = 0
        )
      )
    )
  )
}

## |__ MODULE SERVER ===========================================================

filter <- function(input, output, session){
  reactive({
    
    req(input$variable, input$condition, input$value.variable)

    fullFilter <- paste0(
      input$variable,
      input$condition, 
      input$value.variable
    )
    
    return(fullFilter)
    
  })
}

# Shiny ########################################################################

## |__ UI ======================================================================

ui <- fixedPage(
  fixedRow(
    column(
      width = 5,
      selectInput(
        inputId = "userDataset",
        label   = paste0("Select dataset"),
        choices = c("Choose" = "", ls("package:datasets"))
      ),
      h5(""),
      actionButton("insertBtn", "Add another filter")
    ),
    column(
      width = 7, 
      tableOutput("finalTable")
    )
  )
)

## |__ Server ==================================================================

server <- function(input, output) {
  
  ### \__ Get dataset from user selection ------------------------------------
  
  originalDF <- reactive({
    
    req(input$userDataset)
    
    tmpData <- eval(parse(text = paste0("datasets::", input$userDataset)))
    
    if (!class(tmpData) == "data.frame") {
      stop("Please select a dataset of class data.frame")
    }
    
    tmpData
    
  })
  
  ### \__ Get the column names -----------------------------------------------
  
  columnNames <- reactive({
    
    req(input$userDataset)
    
    tmpData <- eval(parse(text = paste0("datasets::", input$userDataset)))
    
    names(tmpData)  
      
  })
  
  ### \__ Create Reactive Filter ---------------------------------------------
  
  tmpFilters <- reactiveValues()
  
  ### \__ First UI Element ---------------------------------------------------
  ### Add first UI element with column names
  
  observeEvent(input$userDataset, {
    insertUI(
      selector = "h5",
      where    = "beforeEnd",
      ui       = tagList(variablesUI(paste0("var", 1), 1, columnNames()))
    )
  })
  
  ### Update Reactive Filter with first filter
  
  filter01 <- callModule(filter, paste0("var", 1))
  
  observe(tmpFilters[['1']] <- filter01())
  
  ### \__ Other UI Elements --------------------------------------------------
  ### Add other UI elements with column names and update the filter 
  
  observeEvent(input$insertBtn, {
    
    btn <- sum(input$insertBtn, 1)
    
    insertUI(
      selector = "h5",
      where    = "beforeEnd",
      ui       = tagList(variablesUI(paste0("var", btn), btn, columnNames()))
    )
    
    newFilter <- callModule(filter, paste0("var", btn))
    
    observeEvent(newFilter(), {
      tmpFilters[[paste0("'", btn, "'")]] <- newFilter()
    })
    
  })
  
  ### \__ Dataset with Filtered Results --------------------------------------
  
  resultsFiltered <- reactive({
    
    req(filter01())
    
    tmpDF <- originalDF()
    
    tmpList <- reactiveValuesToList(tmpFilters)
    
    if (length(tmpList) > 1) {
      tmpListFilters <- paste(tmpList, "", collapse = "& ")
    } else {
      tmpListFilters <- unlist(tmpList)
    }
    
    tmpResult <- subset(tmpDF, eval(parse(text = tmpListFilters)))
    
    tmpResult
    
  })
  
  ### \__ Print the Dataset with Filtered Results ----------------------------
  
  output$finalTable <- renderTable({
    
    req(input$userDataset)
    
    if (is.null(tmpFilters[['1']])) {
      head(originalDF(), 10)
      
    } else {
      head(resultsFiltered(), 10)
    }

  })
}

#------------------------------------------------------------------------------#
shinyApp(ui, server)

# End