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

Question

下面的selectizeGroupUI()示例代码非常适合我的需要。 但是，默认情况下，首次调用它时会在用户应用任何过滤器之前选择并显示整个数据集。

我的问题是我使用它的数据集非常大，需要一些时间来加载。 有没有办法将初始数据集视图限制为数据框的子集（在此示例中，制造商 = Audi），并且用户单击另一个要添加的按钮以显示完整的数据集？

示例代码：

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

由于我们正在处理一个模块（并且输入不能直接访问），我修改了 function selectizeGroupServer以包含manufacturer输入的更新程序。 新的 function 被称为selectizeGroupServer_custom

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

新模块：

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

应用程序：

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)