从shinyWidgets使用selectizeGroupUI时，如何将默认选择限制为指定的数据子集？

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)

Answer 1

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)