CODEWITHSUNDEEP
rdynamicinputshiny
statechular
statechular

Reputation: 273

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

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 described by the below graph enter image description here The select input "Variable 1" will display all the column names of the data uploaded by the user and the selectize input "Value" will display all the unique values of the corresponding column selected in "Variable 1". Ideally, the user will be able to add as many such rows ("Variable X" + "Value") as possible by some sort of trigger, one possibility being clicking the "Add more" action button.

A possible solution

After looking up online, I've found one promising solution given by Nick Carchedi pasted 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("The crux of the problem is to dynamically 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 resets to Option 1."),

        p("I suppose one hack would be to store the values of all existing inputs prior
          to adding a new input. Then,", code("updateSelectInput()"), "could be used to 
          return inputs to their previously set values, but I'm wondering if there is a 
          more efficient method of doing this.")
    )
))

server.R

library(shiny)

shinyServer(function(input, output) {

    # Initialize list of inputs
    inputTagList <- tagList()

    output$allInputs <- renderUI({
        # Get value of button, which represents number of times pressed
        # (i.e. number of inputs added)
        i <- input$appendInput
        # Return if button not pressed yet
        if(is.null(i) || i < 1) return()
        # Define unique input id and label
        newInputId <- paste0("input", i)
        newInputLabel <- paste("Input", i)
        # Define new input
        newInput <- selectInput(newInputId, newInputLabel,
                                c("Option 1", "Option 2", "Option 3"))
        # Append new input to list of existing inputs
        inputTagList <<- tagAppendChild(inputTagList, newInput)
        # Return updated list of inputs
        inputTagList
    })

})

The downside

As pointed by Nick Carchedi himself, all the existing input widgets will undesirably get reset every time when a new one is added.

A promising solution for data subsetting/filtering in Shiny

As suggested by warmoverflow, the datatable function in DT package provides a nice way to filter the data in Shiny. See below a minimal example with data filtering enabled.

library(shiny)
shinyApp(
    ui = fluidPage(DT::dataTableOutput('tbl')),
    server = function(input, output) {
        output$tbl = DT::renderDataTable(
            iris, filter = 'top', options = list(autoWidth = TRUE)
        )
    }
)

If you are going to use it in your Shiny app, there are some important aspects that are worth noting.

  1. Filtering box type
    • For numeric/date/time columns: range sliders are used to filter rows within ranges
    • For factor columns: selectize inputs are used to display all possible categories
    • For character columns: ordinary search boxes are used
  2. How to obtain the filtered data
    • Suppose the table output id is tableId, use input$tableId_rows_all as the indices of rows on all pages (after the table is filtered by the search strings). Please note that input$tableId_rows_all returns the indices of rows on all pages for DT (>= 0.1.26). If you use the DT version by regular install.packages('DT'), only the indices of the current page are returned
    • To install DT (>= 0.1.26), refer to its GitHub page
  3. Column width
    • If the data have many columns, column width and filter box width will be narrow, which makes it hard to see the text as report here

Still to be solved

Despite some known issues, datatable in DT package stands as a promising solution for data subsetting in Shiny. The question itself, i.e. how to dynamically append arbitrary number of input widgets in Shiny, nevertheless, is interesting and also challenging. Until people find a good way to solve it, I will leave this question open :)

Thank you!

Upvotes: 15

Views: 6475

Answers (4)

ogustavo
ogustavo

Reputation: 586

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):

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

If we want to add a third filter:

enter image description here

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

Upvotes: 4

qfazille
qfazille

Reputation: 1671

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())

Upvotes: 2

Motin
Motin

Reputation: 5063

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)

Upvotes: 1

ogustavo
ogustavo

Reputation: 586

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)

Upvotes: 7

Related Questions