类似于Shiny中的过滤器的Excel

这篇文章讲述了如何在shiny应用程序中实现类似excel的过滤和排序菜单。大多数利益相关者对MS Excel非常熟悉，在涉及到数据操作时，他们一般要求在其他应用程序或软件中实现类似的功能。最近我被问到如何在shiny web应用程序中实现类似Excel的过滤器。

MS Excel中过滤选项的特点

1. MS Excel允许你通过点击你想要的复选框中的值从过滤器中选择多个值。
2. 一次性选择/取消选择下拉菜单的所有唯一值，而不需要手动逐个进行选择。
3. 搜索栏功能可以搜索文本并相应地显示相关的复选框
4. 允许你对数据进行升序和降序排序
5. 高级过滤：应用逻辑条件来过滤数值

在这篇文章中，我们已经涵盖了上述所有的功能，除了最后一项。此外，我们还实现了一个在Excel中缺少的功能--显示过滤器的选定值。

下面的程序使用了shinyWidgets 包和它的小工具。因此，安装该软件包是很重要的。

# Required libraries
library(shiny)
library(shinyWidgets)
library(dplyr)
library(DT)

# Constants
df <- iris #Dataframe Name
cols <- "Species" #Column for filtering / sorting

# Show selected values on button
Concatenate <- function(x, defaultText = "Show Values") {
  
  if(length(x)>0) {
    ifelse(nchar(paste(x,collapse = ", "))>25,
           paste(length(x),"selected"), 
           paste(x,collapse = ", "))
  } else {
    defaultText
  }
  
}

# Choices
letchoice <- unique(as.character(df[[cols]]))

# ------------------------
# App starts from here
# ------------------------

ui <- fluidPage(
  
  tags$head(tags$style("

.btn-dropdown-input button {background-color: #f3f3f3 !important;
    border: 1px solid #ddd; text-align:left; width: 100%; max-width: 100%;
}
    
.btn-dropdown-input .dropdown-toggle::after {
 content: '\\e114';
 font-family: \"Glyphicons Halflings\";
 margin-right: 0.3em;
 font-style: normal;
 float: right;
 border: none;
 font-size: 12px;
 color: #444;
}

.checkbox input {
    accent-color: black;
}

.btn-dropdown-input .caret {
  display: none;
}

")),
  
  tags$script('setTimeout(function(){
$("#asc, #desce").click(function() {
  $(".btn-dropdown-input.shiny-bound-input.open").removeClass("open"); 
});}, 200);'),
  
  titlePanel("Excel Like Filter"),
  
  fluidRow(
    column(
      width = 3,
      dropdownButton(
        inputId = "dropdownbtn",
        label = "Filter column", 
        status = "default",
        circle = FALSE,
        width = 300,
        
        fluidRow(
          column(width = 12,
                 actionGroupButtons(
                   inputIds = c("asc", "desce"),
                   labels = list(tags$span(icon("sort-alpha-asc"), "Sort A to Z"),
                                 tags$span(icon("sort-alpha-desc"), "Sort Z to A")
                   ),
                   fullwidth = T
                 ))
        ),
        
        div(style="margin-bottom:1em;"),
        
        textInputIcon(
          inputId = "search", label = NULL,
          placeholder = "Search",
          icon = icon("search"),
          width = "100%"
        ),
        
        fluidRow(
          column(width = 12,
                 actionGroupButtons(
                   inputIds = c("all", "deselect"),
                   labels = list(tags$span(icon("check"),"Select All"), 
                                 tags$span(icon("remove"), "Deselect All")
                   ),
                   fullwidth = T
                 ))
        ),
        br(),
        
        checkboxGroupInput(inputId = "mycheckbox", 
                           label = NULL, 
                           choices = letchoice,
                           width = '100%'
        )
      )
    ),
    
    column(
      width = 6,
      dataTableOutput("mytable")
    )
  )
)

server <- function(input, output, session) {
  
  # Button Labels Change
  observeEvent(input$mycheckbox, {
    
    updateActionButton(
      session = session, 
      inputId = "dropdownbtn",
      label = Concatenate(input$mycheckbox, "Filter column")
    )
    
  }, ignoreNULL = FALSE, ignoreInit = TRUE)
  
  # Live Search
  observeEvent(input$search, {
    
    updateCheckboxGroupInput(
      session = session, 
      inputId = "mycheckbox", 
      choices = letchoice[grepl(paste0(".*",
                                       input$search,
                                       ".*"), letchoice,
                                ignore.case = T)]
    )
    
  })
  
  
  # Sorting ascending
  myval<- reactiveValues()
  myval$count <- 0
  observeEvent(input$asc, {
    
    updateCheckboxGroupInput(
      session = session, inputId = "mycheckbox", selected = letchoice
    )
    
    myval$count <- 1
  })
  
  # Sorting descending
  observeEvent(input$desce, {
    
    updateCheckboxGroupInput(
      session = session, inputId = "mycheckbox", selected = letchoice
    )
    
    myval$count <- 2
    
  })
  
  
  # Select all
  observeEvent(input$all, {
    updateCheckboxGroupInput(
      session = session, inputId = "mycheckbox", selected = letchoice
    )
  })
  
  # Deselect all
  observeEvent(input$deselect, {
    
    updateCheckboxGroupInput(
      session = session, inputId = "mycheckbox", selected = ""
    )
                        
    updateTextInputIcon(session = session, 
                        inputId = "search",
                        value = "",
                        placeholder = "Search",
                        icon = icon("search"))
    
  })
  
  # Datatable
  cols <- sym(cols)
  output$mytable = renderDT(
    df %>% 
      dplyr::filter(!!cols %in% input$mycheckbox) %>% 
      {if(myval$count == 1) {
        arrange(., !!cols)
      } else if (myval$count > 1)  {
        arrange(., desc(!!cols))
      } else {
        .
      }
      }
  )
  
  
}

shinyApp(ui = ui, server = server)

为了给自己的项目定制上述代码，你可以改变常量df 和cols 。它们指的是你想要过滤的数据框架和列。