When using selectizeGroupUI from shinyWidgets, how to limit default selection to a specified subset of data?

Question

The below example code for selectizeGroupUI() works great for my needs. However by default when first invoking it selects and shows the entire dataset, before the user applies any filters.

My problem is the dataset I'm using this for is very large and takes some time to load. Is there a way to limit the initial dataset view to a subset of the data frame (in this example, manufacturer = Audi), and the user clicks another to-be-added button in order to show the complete dataset?

Example code:

library(shiny)
library(shinyWidgets)

data("mpg", package = "ggplot2")

ui <- fluidPage(
  fluidRow(
    column(
      width = 10, offset = 1,
      tags$h3("Filter data with selectize group"),
      panel(
        checkboxGroupInput(
          inputId = "vars",
          label = "Variables to use:",
          choices = c("manufacturer", "model", "trans", "class"),
          selected = c("manufacturer", "model", "trans", "class"),
          inline = TRUE
        ),
        selectizeGroupUI(
          id = "my-filters",
          params = list(
            manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
            model = list(inputId = "model", title = "Model:"),
            trans = list(inputId = "trans", title = "Trans:"),
            class = list(inputId = "class", title = "Class:")
          )
        ),
        status = "primary"
      ),
      DT::dataTableOutput(outputId = "table")
    )
  )
)

server <- function(input, output, session) {
  
  vars_r <- reactive({
    input$vars
  })
  
  res_mod <- callModule(
    module = selectizeGroupServer,
    id = "my-filters",
    data = mpg,
    vars = vars_r
  )
  
  output$table <- DT::renderDataTable({
    req(res_mod())
    res_mod()
  })
}

shinyApp(ui, server)

Please don’t add tags to the title gratuitously — I’m seeing in your question history that you always do this. It isn’t necessary. — Konrad Rudolph, Dec 13 '21 at 14:15
By tags, do you mean a function name, like in this case selectizeGroupUI? — Curious Jorge - user9788072, Dec 13 '21 at 14:45
@CuriousJorge-user9788072 Tags are the topics in blue boxes at the bottom of the question, to the left of the *Edit tags* link. Currently the question has tags `r`, `select`, `shiny`, and `shinywidgets`. — Gregor Thomas, Dec 13 '21 at 14:55
@CuriousJorge-user9788072 Can the table be empty and only start rendering after the user selected at least one filter? Or preferably you want manufacturer start with one selection like for example audi? — jpdugo17, Dec 13 '21 at 18:57
Hi jpdugo17 - preferably, it would start with one selection, like Audi, so the user can quickly grasp what's there — Curious Jorge - user9788072, Dec 13 '21 at 19:00

jpdugo17 · Accepted Answer · 2021-12-14T14:13:08.903

Since we are dealing with a module (and the inputs are not directly accessible), I modified the function selectizeGroupServer To include an updater for manufacturer input. The new function is called selectizeGroupServer_custom

    observe({
    updateSelectInput(inputId = 'manufacturer', choices = unique(rv$data$manufacturer), selected = 'audi')
    })

new module:

selectizeGroupServer_modified <- 
function(input, output, session, data, vars) 
{
  
  `%inT%` <- function(x, table) {
    if (!is.null(table) && ! "" %in% table) {
      x %in% table
    } else {
      rep_len(TRUE, length(x))
    }
  }
  
  ns <- session$ns
  shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"), 
                      display = "none")
  rv <- reactiveValues(data = NULL, vars = NULL)
  observe({
    if (is.reactive(data)) {
      rv$data <- data()
    }
    else {#this will be the first data
      rv$data <- as.data.frame(data)
    }
    if (is.reactive(vars)) { #this will be the data type for vars
      rv$vars <- vars()
    }
    else {
      rv$vars <- vars
    }
    for (var in names(rv$data)) {
      if (var %in% rv$vars) {
        shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0("container-", 
                                                              var)), display = "table-cell")
      }
      else {
        shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0("container-", 
                                                              var)), display = "none")
      }
    }
  })
  observe({
    lapply(X = rv$vars, FUN = function(x) {
      vals <- sort(unique(rv$data[[x]]))
      updateSelectizeInput(session = session, inputId = x, 
                           choices = vals, server = TRUE)
      
      #CODE INSERTED HERE
      if (x == 'manufacturer') {
        updateSelectizeInput(session = session, inputId = x, 
                             choices = vals, server = TRUE, selected = 'manufacturer')
      }
      
      
    })
  })
  observeEvent(input$reset_all, {
    lapply(X = rv$vars, FUN = function(x) {
      vals <- sort(unique(rv$data[[x]]))
      updateSelectizeInput(session = session, inputId = x, 
                           choices = vals, server = TRUE)
    })
  })
  observe({
    vars <- rv$vars
    lapply(X = vars, FUN = function(x) {
      ovars <- vars[vars != x]
      observeEvent(input[[x]], {
        data <- rv$data
        indicator <- lapply(X = vars, FUN = function(x) {
          data[[x]] %inT% input[[x]]
        })
        indicator <- Reduce(f = `&`, x = indicator)
        data <- data[indicator, ]
        if (all(indicator)) {
          shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"), 
                              display = "none")
        }
        else {
          shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"), 
                              display = "block")
        }
        for (i in ovars) {
          if (is.null(input[[i]])) {
            updateSelectizeInput(session = session, inputId = i, 
                                 choices = sort(unique(data[[i]])), server = TRUE)
          }
        }
        if (is.null(input[[x]])) {
          updateSelectizeInput(session = session, inputId = x, 
                               choices = sort(unique(data[[x]])), server = TRUE)
        }
      }, ignoreNULL = FALSE, ignoreInit = TRUE)
    })
  })
  
    observe({
    updateSelectInput(inputId = 'manufacturer', choices = unique(rv$data$manufacturer), selected = 'audi')
    })
   
  
  return(reactive({
    data <- rv$data
    vars <- rv$vars
    indicator <- lapply(X = vars, FUN = function(x) {
       `%inT%`(data[[x]], input[[x]]) 
    })
    indicator <- Reduce(f = `&`, x = indicator)
    data <- data[indicator, ]
    return(data)
  }))
}

app:

library(shiny)
library(shinyWidgets)

data("mpg", package = "ggplot2")

ui <- fluidPage(
  fluidRow(
    column(
      width = 10, offset = 1,
      tags$h3("Filter data with selectize group"),
      panel(
        checkboxGroupInput(
          inputId = "vars",
          label = "Variables to use:",
          choices = c("manufacturer", "model", "trans", "class"),
          selected = c("manufacturer", "model", "trans", "class"),
          inline = TRUE
        ),
        selectizeGroupUI(
          id = "my-filters",
          params = list(
            manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
            model = list(inputId = "model", title = "Model:"),
            trans = list(inputId = "trans", title = "Trans:"),
            class = list(inputId = "class", title = "Class:")
          )
        ),
        status = "primary"
      ),
      DT::dataTableOutput(outputId = "table")
    )
  )
)

server <- function(input, output, session) {
  
  
  
  vars_r <- reactive({
    input$vars
  })
  
  res_mod <- callModule(
    module = selectizeGroupServer_modified,
    id = "my-filters",
    data = mpg,
    vars = vars_r
  )
  
  
  
  output$table <- DT::renderDataTable({
    res_mod()
  })
}


shinyApp(ui, server)

EDIT:

If we want to have a button that says "show all data", we can modify selectizeGroupUI. The new name will be selectizeGroupUI_custom

Modules and App code:

library(shiny)
library(shinyWidgets)

# SERVER MODULE -----------------------------------------------------------


selectizeGroupServer_modified <-
  function(input, output, session, data, vars) {
    `%inT%` <- function(x, table) {
      if (!is.null(table) && !"" %in% table) {
        x %in% table
      } else {
        rep_len(TRUE, length(x))
      }
    }

    ns <- session$ns
    shinyWidgets:::toggleDisplayServer(
      session = session, id = ns("reset_all"),
      display = "none"
    )
    rv <- reactiveValues(data = NULL, vars = NULL)
    observe({
      if (is.reactive(data)) {
        rv$data <- data()
      } else { # this will be the first data
        rv$data <- as.data.frame(data)
      }
      if (is.reactive(vars)) { # this will be the data type for vars
        rv$vars <- vars()
      } else {
        rv$vars <- vars
      }
      for (var in names(rv$data)) {
        if (var %in% rv$vars) {
          shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0(
            "container-",
            var
          )), display = "table-cell")
        } else {
          shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0(
            "container-",
            var
          )), display = "none")
        }
      }
    })
    observe({
      lapply(X = rv$vars, FUN = function(x) {
        vals <- sort(unique(rv$data[[x]]))
        updateSelectizeInput(
          session = session, inputId = x,
          choices = vals, server = TRUE
        )
      })
    })
    observeEvent(input$reset_all, {
      lapply(X = rv$vars, FUN = function(x) {
        vals <- sort(unique(rv$data[[x]]))
        updateSelectizeInput(
          session = session, inputId = x,
          choices = vals, server = TRUE
        )
      })
    })
    observe({
      vars <- rv$vars
      lapply(X = vars, FUN = function(x) {
        ovars <- vars[vars != x]
        observeEvent(input[[x]],
          {
            data <- rv$data
            indicator <- lapply(X = vars, FUN = function(x) {
              data[[x]] %inT% input[[x]]
            })
            indicator <- Reduce(f = `&`, x = indicator)
            data <- data[indicator, ]
            if (all(indicator)) {
              shinyWidgets:::toggleDisplayServer(
                session = session, id = ns("reset_all"),
                display = "none"
              )
            } else {
              shinyWidgets:::toggleDisplayServer(
                session = session, id = ns("reset_all"),
                display = "block"
              )
            }
            for (i in ovars) {
              if (is.null(input[[i]])) {
                updateSelectizeInput(
                  session = session, inputId = i,
                  choices = sort(unique(data[[i]])), server = TRUE
                )
              }
            }
            if (is.null(input[[x]])) {
              updateSelectizeInput(
                session = session, inputId = x,
                choices = sort(unique(data[[x]])), server = TRUE
              )
            }
          },
          ignoreNULL = FALSE,
          ignoreInit = TRUE
        )
      })
    })

    observe({
      updateSelectInput(inputId = "manufacturer", choices = unique(rv$data$manufacturer), selected = "audi")
    })


    return(reactive({
      data <- rv$data
      vars <- rv$vars
      indicator <- lapply(X = vars, FUN = function(x) {
        `%inT%`(data[[x]], input[[x]])
      })
      indicator <- Reduce(f = `&`, x = indicator)
      data <- data[indicator, ]
      return(data)
    }))
  }

# UI MODULE ---------------------------------------------------------------


selectizeGroupUI_custom <-
  function(id, params, label = NULL, btn_label = "Reset filters", inline = TRUE) {
    ns <- NS(id)
    if (inline) {
      selectizeGroupTag <- tagList(
        ##### NEW LOCATION FOR THE BUTTON #####
        actionButton(
          inputId = ns("reset_all"), label = btn_label,
          style = "float: left;"
          ##### NEW LOCATION FOR THE BUTTON #####
        ),
        tags$b(label), tags$div(
          class = "btn-group-justified selectize-group",
          role = "group", `data-toggle` = "buttons", lapply(
            X = seq_along(params),
            FUN = function(x) {
              input <- params[[x]]
              tagSelect <- tags$div(
                class = "btn-group",
                id = ns(paste0("container-", input$inputId)),
                selectizeInput(
                  inputId = ns(input$inputId),
                  label = input$title, choices = input$choices,
                  selected = input$selected, multiple = ifelse(is.null(input$multiple),
                    TRUE, input$multiple
                  ), width = "100%",
                  options = list(
                    placeholder = input$placeholder,
                    plugins = list("remove_button"), onInitialize = I("function() { this.setValue(\"\"); }")
                  )
                )
              )
              return(tagSelect)
            }
          )
        )
      )
    } else {
      selectizeGroupTag <- tagList(tags$b(label), lapply(
        X = seq_along(params),
        FUN = function(x) {
          input <- params[[x]]
          tagSelect <- selectizeInput(
            inputId = ns(input$inputId),
            label = input$title, choices = input$choices,
            selected = input$selected, multiple = ifelse(is.null(input$multiple),
              TRUE, input$multiple
            ), width = "100%", options = list(
              placeholder = input$placeholder,
              plugins = list("remove_button"), onInitialize = I("function() { this.setValue(\"\"); }")
            )
          )
          return(tagSelect)
        }
      ), actionLink(
        inputId = ns("reset_all"), label = btn_label,
        icon = icon("remove"), style = "float: right;"
      ))
    }
    tagList(
      singleton(tagList(tags$link(
        rel = "stylesheet", type = "text/css",
        href = "shinyWidgets/modules/styles-modules.css"
      ), shinyWidgets:::toggleDisplayUi())),
      selectizeGroupTag
    )
  }


# APP ---------------------------------------------------------------------



data("mpg", package = "ggplot2")

ui <- fluidPage(
  fluidRow(
    column(
      width = 10, offset = 1,
      tags$h3("Filter data with selectize group"),
      panel(
        checkboxGroupInput(
          inputId = "vars",
          label = "Variables to use:",
          choices = c("manufacturer", "model", "trans", "class"),
          selected = c("manufacturer", "model", "trans", "class"),
          inline = TRUE
        ),
        selectizeGroupUI_custom(
          id = "my-filters",
          params = list(
            manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
            model = list(inputId = "model", title = "Model:"),
            trans = list(inputId = "trans", title = "Trans:"),
            class = list(inputId = "class", title = "Class:")
          ), btn_label = "Show all data"
        ),
        status = "primary"
      ),
      DT::dataTableOutput(outputId = "table")
    )
  )
)

########### SERVER###########

server <- function(input, output, session) {
  vars_r <- reactive({
    input$vars
  })

  res_mod <- callModule(
    module = selectizeGroupServer_modified,
    id = "my-filters",
    data = mpg,
    vars = vars_r
  )



  output$table <- DT::renderDataTable({
    res_mod()
  })
}


shinyApp(ui, server)

Works beautifully jpdugo17! I'd like to add, in the ui section of the app under checkboxGroupInput(), under choices = c(...), an additional option of "no filter (show all data)". Checking this box would produce all the data. What is the most efficient way to work this into the code? I'm looking for a good place in the module to work but wondering if there's a best way to do this. Would work same as "Reset all" in lower right corner; maybe just change "Reset all" to "Show all data" or something like that? — Curious Jorge - user9788072, Dec 14 '21 at 06:25
@CuriousJorge-user9788072 I modified the old `actionLink` button that said "reset all" with an `actionButton` that says "Show all Data" and is located before the `selectizeInput`'s at the right corner. — jpdugo17, Dec 14 '21 at 14:15

When using selectizeGroupUI from shinyWidgets, how to limit default selection to a specified subset of data?

1 Answers1