Shiny module to interactively filter a data.frame

Module generate inputs to filter data.frame according column's type. Code to reproduce the filter is returned as an expression with filtered data.

Usage

filter_data_ui(id, show_nrow = TRUE, max_height = NULL)

filter_data_server(
  id,
  data = reactive(NULL),
  vars = reactive(NULL),
  name = reactive("data"),
  defaults = reactive(NULL),
  drop_ids = getOption("datamods.filter.drop_ids", default = TRUE),
  widget_char = c("virtualSelect", "select", "picker"),
  widget_num = c("slider", "range"),
  widget_date = c("slider", "range"),
  label_na = "NA",
  value_na = TRUE
)

Arguments

id: Module id. See shiny::moduleServer().
show_nrow: Show number of filtered rows and total.
max_height: Maximum height for filters panel, useful if you have many variables to filter and limited space.
data: shiny::reactive() function returning a data.frame to filter.
vars: shiny::reactive() function returning a character vector of variables for which to add a filter. If a named list, names are used as labels.
name: shiny::reactive() function returning a character string representing data name, only used for code generated.
defaults: shiny::reactive() function returning a named list of variable:value pairs which will be used to set the filters.
drop_ids: Drop columns containing more than 90% of unique values, or than 50 distinct values. Use FALSE to disable or use list(p = 0.9, n = 50) to customize threshold values.
widget_char: Widget to use for character variables: shinyWidgets::pickerInput() or shiny::selectInput() (default).
widget_num: Widget to use for numeric variables: shinyWidgets::numericRangeInput() or shiny::sliderInput() (default).
widget_date: Widget to use for date/time variables: shiny::dateRangeInput() or shiny::sliderInput() (default).
label_na: Label for missing value widget.
value_na: Default value for all NA's filters.

Value

UI: HTML tags that can be included in shiny's UI
Server: a list with four slots:
- filtered: a reactive function returning the data filtered.
- code: a reactive function returning the dplyr pipeline to filter data.
- expr: a reactive function returning an expression to filter data.
- values: a reactive function returning a named list of variables and filter values.

Examples

library(shiny)
library(shinyWidgets)
library(datamods)
library(MASS)

# Add some NAs to mpg
mtcars_na <- mtcars
mtcars_na[] <- lapply(
  X = mtcars_na,
  FUN = function(x) {
    x[sample.int(n = length(x), size = sample(5:10, 1))] <- NA
    x
  }
)

datetime <- data.frame(
  date = seq(Sys.Date(), by = "day", length.out = 300),
  datetime = seq(Sys.time(), by = "hour", length.out = 300),
  num = sample.int(1e5, 300)
)

one_column_numeric <- data.frame(
  var1 = rnorm(100)
)

ui <- fluidPage(
  tags$h2("Filter data.frame"),
  actionButton("saveFilterButton","Save Filter Values"),
  actionButton("loadFilterButton","Load Filter Values"),
  radioButtons(
    inputId = "dataset",
    label = "Data:",
    choices = c(
      "iris",
      "mtcars",
      "mtcars_na",
      "Cars93",
      "datetime",
      "one_column_numeric"
    ),
    inline = TRUE
  ),

  fluidRow(
    column(
      width = 3,
      filter_data_ui("filtering", max_height = "500px")
    ),
    column(
      width = 9,
      progressBar(
        id = "pbar", value = 100,
        total = 100, display_pct = TRUE
      ),
      reactable::reactableOutput(outputId = "table"),
      tags$b("Code dplyr:"),
      verbatimTextOutput(outputId = "code_dplyr"),
      tags$b("Expression:"),
      verbatimTextOutput(outputId = "code"),
      tags$b("Filtered data:"),
      verbatimTextOutput(outputId = "res_str")
    )
  )
)

server <- function(input, output, session) {
  savedFilterValues <- reactiveVal()
  data <- reactive({
    get(input$dataset)
  })

  vars <- reactive({
    if (identical(input$dataset, "mtcars")) {
      setNames(as.list(names(mtcars)[1:5]), c(
        "Miles/(US) gallon",
        "Number of cylinders",
        "Displacement (cu.in.)",
        "Gross horsepower",
        "Rear axle ratio"
      ))
    } else {
      NULL
    }
  })
  
  observeEvent(input$saveFilterButton,{
    savedFilterValues <<- res_filter$values()
  },ignoreInit = T)
  
  defaults <- reactive({
    input$loadFilterButton
    savedFilterValues
  })

  res_filter <- filter_data_server(
    id = "filtering",
    data = data,
    name = reactive(input$dataset),
    vars = vars,
    defaults = defaults,
    widget_num = "slider",
    widget_date = "slider",
    label_na = "Missing"
  )

  observeEvent(res_filter$filtered(), {
    updateProgressBar(
      session = session, id = "pbar",
      value = nrow(res_filter$filtered()), total = nrow(data())
    )
  })

  output$table <- reactable::renderReactable({
    reactable::reactable(res_filter$filtered())
  })


  output$code_dplyr <- renderPrint({
    res_filter$code()
  })
  output$code <- renderPrint({
    res_filter$expr()
  })

  output$res_str <- renderPrint({
    str(res_filter$filtered())
  })

}

if (interactive())
  shinyApp(ui, server)