R/FilterStatesDF.R

In teal.slice: Filter Module for 'teal' Applications

# DFFilterStates ------

#' @name DFFilterStates
#' @docType class
#'
#' @title `FilterStates` subclass for data frames
#'
#' @description Handles filter states in a `data.frame`.
#'
#' @examples
#' # use non-exported function from teal.slice
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
#' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
#'
#' library(shiny)
#' library(shinyjs)
#'
#' # create data frame to filter
#' data_df <- data.frame(
#'   NUM1 = 1:100,
#'   NUM2 = round(runif(100, min = 20, max = 23)),
#'   CHAR1 = sample(LETTERS[1:6], size = 100, replace = TRUE),
#'   CHAR2 = sample(c("M", "F"), size = 100, replace = TRUE),
#'   DATE = seq(as.Date("2020-01-01"), by = 1, length.out = 100),
#'   DATETIME = as.POSIXct(seq(as.Date("2020-01-01"), by = 1, length.out = 100))
#' )
#' data_na <- data.frame(
#'   NUM1 = NA,
#'   NUM2 = NA,
#'   CHAR1 = NA,
#'   CHAR2 = NA,
#'   DATE = NA,
#'   DATETIME = NA
#' )
#' data_df <- rbind(data_df, data_na)
#'
#' # initiate `FilterStates` object
#' filter_states_df <- init_filter_states(
#'   data = data_df,
#'   dataname = "dataset",
#'   datalabel = ("label")
#' )
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   column(4, tags$div(
#'     tags$h4("Active filters"),
#'     filter_states_df$ui_active("fsdf")
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Manual filter control"),
#'     filter_states_df$ui_add("add_filters"), tags$br(),
#'     tags$h4("Condition (i.e. call)"), # display the subset expression generated by this FilterStates
#'     textOutput("call_df"), tags$br(),
#'     tags$h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_df"), tags$br()
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Programmatic filter control"),
#'     actionButton("button1_df", "set NUM1 < 30", width = "100%"), tags$br(),
#'     actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), tags$br(),
#'     actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"), tags$br(),
#'     actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), tags$br(),
#'     actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), tags$br(),
#'     actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), tags$br(),
#'     tags$hr(),
#'     actionButton("button7_df", "remove NUM1", width = "100%"), tags$br(),
#'     actionButton("button8_df", "remove NUM2", width = "100%"), tags$br(),
#'     actionButton("button9_df", "remove CHAR1", width = "100%"), tags$br(),
#'     actionButton("button10_df", "remove CHAR2", width = "100%"), tags$br(),
#'     actionButton("button11_df", "remove DATE", width = "100%"), tags$br(),
#'     actionButton("button12_df", "remove DATETIME", width = "100%"), tags$br(),
#'     tags$hr(),
#'     actionButton("button0_df", "clear all filters", width = "100%"), tags$br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   filter_states_df$srv_add("add_filters")
#'   filter_states_df$srv_active("fsdf")
#'
#'   output$call_df <- renderPrint(filter_states_df$get_call())
#'   output$formatted_df <- renderText(filter_states_df$format())
#'
#'   observeEvent(input$button1_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30)))
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button2_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21)))
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button3_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D")))
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button4_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F")))
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button5_df, {
#'     filter_state <- teal_slices(
#'       teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02"))
#'     )
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button6_df, {
#'     filter_state <- teal_slices(
#'       teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
#'     )
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'
#'   observeEvent(input$button7_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "NUM1"))
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button8_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "NUM2"))
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button9_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "CHAR1"))
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button10_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "CHAR2"))
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button11_df, {
#'     filter_state <- teal_slices(
#'       teal_slice("dataset", "DATE")
#'     )
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button12_df, {
#'     filter_state <- teal_slices(
#'       teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
#'     )
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'
#'   observeEvent(input$button0_df, filter_states_df$clear_filter_states())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @keywords internal
#'
DFFilterStates <- R6::R6Class( # nolint
  classname = "DFFilterStates",
  inherit = FilterStates,

  # public methods ----
  public = list(
    #' @description
    #' Initializes `DFFilterStates` object by setting `dataname`
    #'  and initializing `state_list` (`shiny::reactiveVal`).
    #' This class contains a single `state_list` with no specified name,
    #' which means that when calling the subset function associated with this class
    #' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`).
    #'
    #' @param data (`data.frame`)
    #'   the `R` object which `dplyr::filter` function will be applied on.
    #' @param data_reactive (`function(sid)`)
    #'   should return a `data.frame` object or `NULL`.
    #'   This object is needed for the `FilterState` counts being updated on a change in filters.
    #'   If function returns `NULL` then filtered counts are not shown.
    #'   Function has to have `sid` argument being a character.
    #' @param dataname (`character`)
    #'   name of the data used in the *subset expression*.
    #'   Passed to the function argument attached to this `FilterStates`.
    #' @param datalabel (`character(1)`) optional
    #'   text label.
    #' @param keys (`character`)
    #'   key column names.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL,
                          keys = character(0)) {
      checkmate::assert_function(data_reactive, args = "sid")
      checkmate::assert_data_frame(data)
      super$initialize(data, data_reactive, dataname, datalabel)
      private$keys <- keys
      private$set_filterable_varnames(include_varnames = colnames(private$data))
    }
  ),

  # private members ----
  private = list(
    fun = quote(dplyr::filter)
  )
)