Quokka filters

README.md

Quokka Filters

filtermtcars_reactiveFun.R

library(shiny)
library(DT)

#' Dynamically generate filtering widgets based on a vector's data type
#' @param x A vector
#' @param id An ID to use for the widget
#' @param label A label to use for the widget
create_filter <- function(x, id, label) {
  id <- paste0("modal_filter_", id)
  if (is.numeric(x)) {
    sliderInput(
      inputId = id,
      label = label,
      min = min(x, na.rm = TRUE),
      max = max(x, na.rm = TRUE),
      value = range(x, na.rm = TRUE)
    )
  } else if (is.factor(x)) {
    selectInput(id, label, choices = unique(x))
  } else {
    textInput(id, label, value = "")
  }
}

#' Apply a filter to a vector
#' @param x A vector
#' @param filter A filter. For numeric vectors, a two-element vector containing
#' the min and max values. For factor vectors, a vector of values to include.
#' For character vectors, a string to match.
#' @return A logical vector
apply_filter <- function(x, filter) {
  if (is.numeric(x)) {
    x >= filter[[1]] & x <= filter[[2]]
  } else if (is.factor(x)) {
    x %in% filter
  } else {
    grepl(filter, x, ignore.case = TRUE)
  }
}

#' Create a modal dialog containing filtering widgets for each column in a data frame
build_filter_modal <- function(data) {
  ids <- colnames(data)
  widgets <- Map(create_filter, x = data, id = ids, label = ids)
  modalDialog(
    do.call(tagList, widgets),
    title = "Filter Data",
    footer = actionButton("apply", "Apply Filters", icon = icon("check"))
  )
}

ui <- fluidPage(
  titlePanel("Interactive Column Filtering"),
  mainPanel(

    fluidRow(
      column(
        width = 12,
        align = "left",
        actionButton("filter", icon = icon("filter"), label = "Filter")
      )
    ),

    fluidRow(
      column(
        width = 12,
        tags$div(style = "margin-top: 10px;"),
        DT::DTOutput("mytable"),
        textOutput("activeFilters")
      )
    )
  )
)

server <- function(input, output, session) {

  # Modify mtcars to include a string and factor columns
  all_data <- structure(
    transform(
      mtcars,
      model = rownames(mtcars),
      cyl = factor(cyl),
      gear = factor(gear),
      vs = factor(vs),
      am = factor(am)
    ),
    row.names = seq_len(nrow(mtcars))
  )

  combined_filters <- reactiveVal(value = rep(TRUE, nrow(all_data)))

  # Show the filtering modal
  observeEvent(input$filter, {
    req(all_data)
    showModal(
      build_filter_modal(all_data)
    )
  })

  # Apply the filters
  # Returns a named list of logical vectors, one for each col in the dataframe
  filter_index <- eventReactive(input$apply, {
    message("Applying filters")
    removeModal()

    filter_names <- names(input)[startsWith(names(input), "modal_filter_")]
    names(filter_names) <- sub("modal_filter_", "", filter_names)

    filter_selections <- sapply(filter_names, \(x) input[[x]], simplify = FALSE)
    Map(apply_filter, x = all_data, filter = filter_selections[names(all_data)])
  })

  # Combine logical vectors from each filter into a single logical vector
  observe({
    req(filter_index())
    message("Combining filters")

    # Log the number of rows that match each filter
    message("Rows matching each filter:")
    message(
      sprintf(
        "- %s: %i (%1.0f%%)\n",
        names(filter_index()),
        sapply(filter_index(), sum),
        sapply(filter_index(), mean) * 100
      )
    )

    combined_filters(
      Reduce("&", filter_index())
    )
  })

  filtered_data <- reactive({
    req(combined_filters())
    message(
      sprintf(
        "Filtering data: %i (%1.0f%%) rows match all filters",
        sum(combined_filters()),
        mean(combined_filters()) * 100
      )
    )

    all_data[combined_filters(), ]
  })

  output$mytable <- DT::renderDT({
    req(filtered_data())
    message("Rendering table")
    DT::datatable(
      filtered_data(),
      filter = "top",
      escape = TRUE
    )
  })
}

shinyApp(ui = ui, server = server)

filtermtcars_reactiveVal.R

library(shiny)
library(DT)

ui <- fluidPage(
  tags$head(tags$script(HTML("
    $(document).on('click', 'a.filter', function () {
      var column = $(this).data('column');
      Shiny.setInputValue('filter', column, {priority: 'event'});
    });
  "))),
  DTOutput("mytable"),
  textOutput("activeFilters")
)

fetchmtcars <- function(){
  return(mtcars)
}

server <- function(input, output, session) {
  data <- reactiveVal(fetchmtcars())
  activeFilters <- reactiveVal(list())

  output$mytable <- renderDT({
    datatable(
      data(),
      escape = -1,
      callback = JS("
        table.on('init.dt', function () {
          $.each($('thead th', this), function (i, th) {
            var link = $('<a>')
              .addClass('filter')
              .attr('href', '#')
              .data('column', $(th).text())
              .text($(th).text());
            $(th).empty().append(link);
          });
        });
      ")
    )
  })

  observeEvent(input$filter, {
    showModal(modalDialog(
      checkboxGroupInput("filterValues", "Filter Values",
                         choices = unique(mtcars[[input$filter]]),
                         selected = unique(mtcars[[input$filter]])),
      footer = tagList(
        modalButton("Cancel"),
        actionButton("update", "Update")
      )
    ))
  })

  observeEvent(input$update, {
    removeModal()
    filter <- req(input$filterValues)
    filters <- activeFilters()
    filters[[input$filter]] <- filter
    activeFilters(filters)
    data(mtcars[mtcars[[input$filter]] %in% filter, ])
  })

  output$activeFilters <- renderText({
    filters <- activeFilters()
    if (length(filters) == 0) {
      return("No active filters")
    }
    paste0("Active filters: ", paste(names(filters), sapply(filters, paste, collapse = ", "), sep = ": ", collapse = "; "))
  })
}

shinyApp(ui = ui, server = server)