filters.R

library(shiny)

columnFilterUI <- function(id) {
  ns <- NS(id)
  uiOutput(ns("filter_container"))
}

columnFilter <- function(input, output, session, df, col_num, choice_filter) {
  # This renders a selectInput and only re-renders when the selected data
  # frame changes. (i.e. it doesn't re-render when filters change state.)
  output$filter_container <- renderUI({
    # Don't render if col_num is > actual number of cols
    req(col_num <= ncol(df()))
    
    freezeReactiveValue(input, "filter_value")
    selectInput(session$ns("filter_value"), names(df())[[col_num]],
      choices = sort(unique(df()[,col_num,drop=TRUE])),
      multiple = TRUE)
  })
  
  # When the other filters change, update this filter to remove rows that
  # are filtered out by the other filters' criteria. (We also add in the
  # currently selected values for this filter, so that changing other
  # filters does not cause this filter's selected values to be unselected;
  # while that behavior might make sense logically, it's a poor user
  # experience.)
  observeEvent(choice_filter(), {
    current_values <- input$filter_value
    
    updateSelectInput(session, "filter_value",
      choices = sort(unique(c(current_values, df()[choice_filter(),col_num,drop=TRUE]))),
      selected = current_values
    )
  })
  
  # Return a reactive that is a row index of selected rows, according to
  # just this filter. If this filter shouldn't be taken into account
  # because its col_num is too high, or if there are no values selected,
  # just return TRUE to accept all rows.
  reactive({
    if (col_num > ncol(df())) {
      TRUE
    } else if (!isTruthy(input$filter_value)) {
      TRUE
    } else {
      df()[,col_num,drop=TRUE] %in% input$filter_value
    }
  })
}

columnFilterSetUI <- function(id, maxcol, colwidth) {
  ns <- NS(id)
  
  fluidRow(
    lapply(1:maxcol, function(i) {
      column(colwidth,
        columnFilterUI(ns(paste0("col", i)))
      )
    })
  )
}

columnFilterSet <- function(input, output, session, df, maxcol) {
  
  # Each column filter needs to only display the choices that are
  # permitted after all the OTHER filters have had their say. But
  # each column filter must not take its own filter into account
  # (hence we do filter[-col], not filter, in the reactive below).
  create_choice_filter <- function(col) {
    reactive({
      filter_values <- lapply(filters[-col], do.call, args = list())
      Reduce(`&`, filter_values, TRUE)
    })
  }
  
  # filters is a list of reactive expressions, each of which is a
  # logical vector of rows to be selected.
  filters <- lapply(1:maxcol, function(i) {
    callModule(columnFilter, paste0("col", i), df, i, create_choice_filter(i))
  })
  
  reactive({
    # Unpack the list of reactive expressions to a list of logical vectors
    filter_values <- lapply(filters, do.call, args = list())
    # Combine all the logical vectors using & operator
    selected_rows <- Reduce(`&`, filter_values, TRUE)
    # Return the data frame, filtered by the selected rows
    df()[selected_rows,]
  })
}

ui <- fluidPage(
  selectInput("dataset", "Dataset", c("mtcars", "pressure", "cars"), selected = "mtcars"),
  columnFilterSetUI("filterset", maxcol = 4, colwidth = 3),
  DT::dataTableOutput("table")
)

server <- function(input, output, session) {
  selected_data <- reactive({
    get(input$dataset, "package:datasets")
  })
  
  filtered_data <- callModule(columnFilterSet, "filterset", df = selected_data, maxcol = 4)
  
  output$table <- DT::renderDataTable({ filtered_data() })
}

shinyApp(ui, server)

I have date columns also in my data. Is there a way to additional type of input like dateinput in addition to select input and maintain the same functionality

Thank you @jcheng5, this is exactly what I have been looking for! I've implemented the code and the table filtering works perfectly.

I am also working on implementing a second output to visualize spatial data using renderLeaflet alongside the table on the same shiny app but I have not been successful.

I was wondering if you know how the code could be altered so that it may be applied to polygon geometry data?

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

selected_data <- reactive({dataframe})
          
filtered_data <- callModule(columnFilterSet, "filterset", df = selected_data, maxcol = 10)

# Create table output         
output$table <- DT::renderDT(DT::datatable(filtered_data(), class = 'cell-border stripe', rownames = FALSE))

# Create colour palette
library(viridis)
pal <- colorBin(palette = "viridis", domain = filtered_data()$Value, bins = c(0, 50, 100))

# Create map output    
output$map <- renderLeaflet({
                         addProviderTiles("CartoDB.Positron", options = providerTileOptions(noWrap = TRUE)) %>%
                         addPolygons(data = filtered_data(),
                                              weight = 1, 
                                              opacity = 0.5,
                                              fillOpacity = 0.5,
                                              smoothFactor = 1,
                                              fillColor = ~pal(filtered_data()$Value))
})
}

Thank you for this example @jcheng5 !

One question, how could i return the values that are selected in the inputs (mpeg, cyl etc.) on the server side? Not as logical, but the value selected in selectInput ns "filter_value" (for example 13.3 in mpeg and 8 in cyl).

Appreciate it