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

标签 r select shiny shinywidgets

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

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

示例代码:

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)

最佳答案

由于我们正在处理一个模块(并且不能直接访问输入)，我修改了函数 selectizeGroupServer 以包含一个用于 manufacturer 输入的更新程序。新函数称为 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)

编辑:

如果我们想要一个“显示所有数据”的按钮，我们可以修改selectizeGroupUI。新名称将是 selectizeGroupUI_custom

模块和应用程序代码:

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)

enter image description here

关于r - 使用 shinyWidgets 中的 selectizeGroupUI 时，如何将默认选择限制为指定的数据子集？，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/70336016/

上一篇：python - 什么时候链接列表优先于列表？

下一篇：scala - Databricks SCALA UDF 在注册函数时无法加载类

相关文章：

MySQL:根据已选行中的值选择行

javascript - 如何使用 shinydashboard 检查 Shiny 应用程序中浏览器的浏览器宽度并相应地更改框宽度

R Shiny list2env

r - 根据阈值更改文本颜色

R/openxlsx/查找Excel文件中的第一个非空单元格

r - ggplot 在 for 循环中从数据框中提取行，显示不同的颜色

r - 尽管C++ 11可用，但正在更新R.3.5.1 C++ 11依赖关系中的Rgdal ...

mysql - 大查询 : how to retrieve values in field 1 corresponding to field 2

php - MySQL SELECT 命令确实少找到一个条目

r - 在没有 TRUE 评估的情况下在 R Shiny 中使用 source 命令

©2024 IT工具网  联系我们