Question

我正在编写一个闪亮的函数，它接受数据集并根据设计变量（因子）和响应变量（数字）的存在生成UI组件。

我希望有一个复选框输入来隐藏/显示应用程序中的所有变量（design UI元素），并且还能够根据设计因素的级别过滤掉特定的行。由于数据集中的因子数量未知，因此必须一般生成。

在函数内，在定义ui和server之前，我找到所有因子变量并生成checkboxGroupInputs的相关参数，然后在ui中使用{ {1}}和lapply将它们添加到界面中。但是，我现在需要使用它们来过滤行，我不知道该怎么做。

我准备了一个MWE来说明：

do.call

我的问题是：

[已解决]即使正在创建过滤器复选框（第11:19行），我也无法按预期将它们包含在应用中。
添加完成后，我不确定如何利用它们在第40行周围根据需要过滤行（例如，应该可以从data(iris) iris$Species2 <- iris$Species filterex <- function(data = NULL){ library(shiny) # Get design variables (factors) and response variables: dvars <- names(which(sapply(data, class) == "factor")) rvars <- names(which(sapply(data, class) != "factor")) # Generate inputs for all design factor filters: num_filters <- length(dvars) filters <- list() for (i in 1:num_filters){ filt <- dvars[[i]] filters[[i]] <- list(inputId = filt, label = filt, choices = levels(data[[filt]]), selected = levels(data[[filt]])) } ## UI ############################# ui = fluidPage( titlePanel("Dynamic filtering example"), sidebarPanel( checkboxGroupInput(inputId = "design", label = "Design Variables", choices = dvars, selected = dvars), # Add filter checkboxes: lapply(filters, do.call, what = checkboxGroupInput)), mainPanel( dataTableOutput("data")) ) ## SERVER ######################### server = function(input, output, session) { # SUBSET DESIGN COLUMNS BASED UPON INPUTS: dat_subset <- reactive({ df <- data[, c(input$design, rvars), drop = FALSE] # NEED TO INCORPORATE CODE TO SUBSET ROWS HERE return(df) }) output$data <- renderDataTable({ dat_subset() }) } runApp(list(ui = ui, server = server)) } filterex(iris)取消选中setosa来隐藏这些行行）。

任何建议都会非常感激！我已经查看了许多其他主题，但我遇到的所有解决方案都是针对特定数据集量身定制的（因此变量的数量和名称是先验已知的）。

Answer 1

如果有更好的方法，我很乐意听到它，但我有一个工作原型！这可以显示/隐藏设计变量，并根据选中/取消选中的框过滤行。此外，根据设计选择添加/隐藏过滤器的UI元素：）

filterex <- function(data = NULL){

  # Get design variables (factors) and response variables:
  dvars <- names(which(sapply(data, class) == "factor"))
  rvars <- names(which(sapply(data, class) != "factor"))
  data$internalid <- 1:nrow(data)

  ## UI #############################
  ui = fluidPage(
    titlePanel("Dynamic filtering example"),
    sidebarPanel(
      checkboxGroupInput(inputId = "design", label = "Design Variables",
                         choices = dvars, selected = dvars),
      uiOutput("filters")),
    mainPanel(
      dataTableOutput("data"))
  )

  ## SERVER #########################
  server = function(input, output, session) {

    # Determine checkboxes:
    output$filters <- renderUI({
      filters <- lapply(dvars[dvars == input$design], function(d) {
        list(inputId = d, label = d,
             choices = levels(data[[d]]),
             selected = levels(data[[d]]))
      })
      lapply(filters, do.call, what = checkboxGroupInput)
    })

    # GENERATE REDUCED DATA TABLE:
    dat_subset <- reactive({
      # SUBSET DATA BY DESIGN INPUTS
      df <- data[, c(input$design, rvars, "internalid"), drop = FALSE]

      # SUBSET DATA BY ROWS AND MERGE
      for (i in 1:length(input$design)){
        if(!is.null(input[[input$design[[i]]]])){
          dfs <- lapply(input$design, function(d) {
            df[df[[d]] %in% input[[d]],]
          })
          if (length(dfs) > 1){
            df <- Reduce(function(...) merge(..., all=FALSE), dfs) 
          } else df <- dfs[[1]]
        }        
      }
      return(df)
    })

    output$data <- renderDataTable({
      dat_subset()[,c(input$design, rvars)]
    })
  }
  runApp(list(ui = ui, server = server), launch.browser = TRUE)
}

data(iris)
iris$Species2 <- iris$Species
filterex(iris)

Answer 2

与您到达的解决方案类似，在构建过滤器和动态子集时，请考虑lapply次for次循环：

filterex <- function(data = NULL){

  # Get design variables (factors) and response variables:
  dvars <- names(which(sapply(data, class) == "factor"))
  rvars <- names(which(sapply(data, class) != "factor"))

  # Generate inputs for all design factor filters:
  filters <- lapply(dvars, function(d) {
    list(inputId = d, label = d,
         choices = levels(data[[d]]),
         selected = levels(data[[d]]))
  })

  ## UI #############################
  ui = fluidPage(
    titlePanel("Dynamic filtering example"),
    sidebarPanel(
      checkboxGroupInput(inputId = "design", label = "Design Variables",
                         choices = dvars, selected = dvars),
      # Add filter checkboxes:
      lapply(filters, do.call, what = checkboxGroupInput)),
    mainPanel(
      dataTableOutput("data"))
  )

  ## SERVER #########################
  server = function(input, output, session) {

    # SUBSET DESIGN COLUMNS BASED UPON INPUTS:
    dat_subset <- reactive({
      df <- data[, c(input$design, rvars), drop = FALSE]

      # DF SUBSET LIST
      dfs <- lapply(dvars, function(d) {
        df[df[[d]] %in% input[[d]],]
      })
      # ROW BIND ALL DFs
      df <- do.call(rbind, dfs) 
      return(df)
    })

    output$data <- renderDataTable({
      dat_subset()
    })
  }
  runApp(list(ui = ui, server = server))
}

filterex(iris)

Answer 3

以下是使用tidyverse

的一个选项

library(shiny)
library(dplyr)
library(purrr)

filterex <- function(data = NULL) {
    i1 <-  data %>%
                 summarise_all(is.factor) %>%
                 unlist()
    dvars <- i1 %>%
                names(.)[.]
    rvars <- i1 %>%
                 `!` %>%
                 names(.)[.]

   filters <-dvars %>% 
                map(~list(inputId = ., 
                          label = ., 
                          choices = levels(data[[.]]), 
                          selected = levels(data[[.]])))




  ui = fluidPage(
    titlePanel("Dynamic filtering example"),
    sidebarPanel(
      checkboxGroupInput(inputId = "design",
                          label = "Design Variables",
                          choices = dvars,
                          selected = dvars),
                          map(filters, ~do.call(what = checkboxGroupInput, .))),
                          mainPanel(dataTableOutput("data"))
    )



  server = function(input, output, session) {

    dat_subset <- reactive({
        df <-  data %>%
                 select(input$design, rvars) 
        dvars %>% 
              map2_df(list(df), ~.y  %>%
                        filter_at(.x, all_vars(. %in% input[[.x]])))



    })  
    output$data <- renderDataTable({
              dat_subset()
      })

    }

  runApp(list(ui = ui, server = server))
    }

使用'iris'上的功能

filterex(iris)

输出得到

从闪亮的动态变量中过滤数据帧行

3 个答案: