如何在Shiny DataTables中过滤含多级别值的列？

问题概述 #

需要在Shiny应用中通过复选框过滤包含多值的CONSEQUENCE列（例如值为stop gained, frameshift），原代码存在两个问题：

• 初始代码运行时出现dim(X) must have a positive length错误
• 改用map+reduce消除错误后，部分多值（如synonymous）仍无法正确匹配过滤

原代码 #

library(dplyr)
library(shiny)
library(shinydashboard)
library(DT)

parse_levels <- function(var) {
  concat_levels <- paste0(unique(var), collapse=", ")
  # split the strings
  parsed_levels <- unlist(strsplit(concat_levels, ', '))
  uniq_levels <- unique(parsed_levels)
  return(uniq_levels)
}

filter_variables <- function(var, in_val){
  if (is.factor(var)) {
    var %in% in_val
  } else if (is.character(var)) {
    # multiple levels create a list of logical vector
     list_log <- sapply(in_val, function(x){
      grepl(x, var)
    })
     apply(list_log, 1, any)
  } else {
    # in case neither return TRUE
    TRUE
  }
}

ui <- fluidPage(
  uiOutput("filters_ui"),
  textOutput("text"),
  DT::DTOutput("table")
)

server <- function(input, output, session) {
  
  filters <- reactive({
    filter_variables(df$CONSEQUENCE, input$csq)
  })
  
  output$filters_ui <- renderUI({
    tagList(
      checkboxGroupInput("csq", "csq", choices=parse_levels(df$CONSEQUENCE), 
                         selected = parse_levels(df$CONSEQUENCE))
    )
  })
  output$table <- renderDataTable({
    df %>% select(CLNSIG, CONSEQUENCE) %>% filter(filters())})
}

shinyApp(ui, server)

运行错误信息 #

Warning: Error in filter: Problem while computing `..1 = filters()`.
Caused by error in `apply()`:
! dim(X) must have a positive length

测试数据（df前10行） #

structure(list(CLNSIG = c(NA, "Uncertain significance", "Likely benign", 
NA, NA, NA, NA, NA, NA, "Pathogenic/Likely pathogenic"), CONSEQUENCE = c("stop gained, frameshift", 
"missense", "missense", "frameshift", "frameshift", "frameshift", 
"stop gained", "missense", "frameshift", "splice region, synonymous"
)), row.names = c(NA, 10L), class = "data.frame")

问题分析与修正方案 #

错误根源 #

1. 初始代码中，当input$csq为空（比如用户取消所有复选框）时，sapply返回空对象，apply因无维度信息报错
2. 改用map+reduce后，若未处理input$csq为空的情况，仍会出现逻辑错误；同时grepl匹配时未做精确匹配，可能导致部分值无法被正确识别

修正后的完整代码 #

library(dplyr)
library(shiny)
library(shinydashboard)
library(DT)
library(purrr)

parse_levels <- function(var) {
  concat_levels <- paste0(unique(var), collapse=", ")
  parsed_levels <- unlist(strsplit(concat_levels, ', '))
  unique(parsed_levels)
}

filter_variables <- function(var, in_val){
  # 处理输入为空的情况：返回所有行
  if (length(in_val) == 0) return(rep(TRUE, length(var)))
  
  if (is.factor(var)) {
    var %in% in_val
  } else if (is.character(var)) {
    # 使用正则确保精确匹配单个值，避免部分匹配
    map(in_val, ~grepl(paste0("(^|, )", .x, "(, |$)"), var)) %>%
      reduce(`|`)
  } else {
    rep(TRUE, length(var))
  }
}

ui <- fluidPage(
  uiOutput("filters_ui"),
  DT::DTOutput("table")
)

server <- function(input, output, session) {
  # 定义测试数据
  df <- structure(list(CLNSIG = c(NA, "Uncertain significance", "Likely benign", 
                                  NA, NA, NA, NA, NA, NA, "Pathogenic/Likely pathogenic"), CONSEQUENCE = c("stop gained, frameshift", 
                                                                                                           "missense", "missense", "frameshift", "frameshift", "frameshift", 
                                                                                                           "stop gained", "missense", "frameshift", "splice region, synonymous"
                                  )), row.names = c(NA, 10L), class = "data.frame")
  
  filters <- reactive({
    filter_variables(df$CONSEQUENCE, input$csq)
  })
  
  output$filters_ui <- renderUI({
    checkboxGroupInput(
      "csq", 
      "变异后果过滤", 
      choices = parse_levels(df$CONSEQUENCE), 
      selected = parse_levels(df$CONSEQUENCE)
    )
  })
  
  output$table <- renderDataTable({
    df %>% 
      select(CLNSIG, CONSEQUENCE) %>% 
      filter(filters())
  })
}

shinyApp(ui, server)

关键修正点 #

1. 空输入处理：在filter_variables开头判断in_val长度，为空时返回全TRUE，避免后续函数报错
2. 精确值匹配：使用正则表达式(^|, )和(, |$)确保匹配完整的单个值，比如synonymous只会命中包含该完整值的行（如splice region, synonymous）
3. 代码简化：精简parse_levels函数逻辑，移除无用的textOutput组件

验证效果 #

• 勾选synonymous时，会正确显示第10行（splice region, synonymous）
• 勾选stop gained时，会显示第1行（stop gained, frameshift）和第7行（stop gained）
• 取消所有勾选时，会显示全部行

内容的提问来源于stack exchange，提问作者Cocoa99