R/FilterStates.R

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

# FilterStates ------

#' @name FilterStates
#' @docType class
#' @title `FilterStates` `R6` class
#'
#' @description
#' Abstract class that manages adding and removing `FilterState` objects
#' and builds a *subset expression*.
#'
#' A `FilterStates` object tracks all condition calls
#' (logical predicates that limit observations) associated with a given dataset
#' and composes them into a single reproducible `R` expression
#' that will assign a subset of the original data to a new variable.
#' This expression is hereafter referred to as *subset expression*.
#'
#' The *subset expression* is constructed differently for different
#' classes of the underlying data object and `FilterStates` sub-classes.
#' Currently implemented for `data.frame`, `matrix`,
#' `SummarizedExperiment`, and `MultiAssayExperiment`.
#'
#' @keywords internal
#'
FilterStates <- R6::R6Class( # nolint
  classname = "FilterStates",

  # public members ----
  public = list(
    #' @description
    #' Initializes `FilterStates` object by setting
    #' `dataname`, and `datalabel`.
    #'
    #' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`)
    #'   the `R` object which `subset` function is applied on.
    #' @param data_reactive (`function(sid)`)
    #'   should return an object of the same type as `data` 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(1)`)
    #'   name of the dataset, used in the subset expression.
    #'   Passed to the function argument attached to this `FilterStates`.
    #' @param datalabel (`character(1)`) optional
    #'   text label.
    #'
    #' @return
    #' Object of class `FilterStates`, invisibly.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL) {
      checkmate::assert_string(dataname)
      logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
      checkmate::assert_function(data_reactive, args = "sid")
      checkmate::assert_string(datalabel, null.ok = TRUE)

      private$dataname <- dataname
      private$datalabel <- datalabel
      private$dataname_prefixed <- dataname
      private$data <- data
      private$data_reactive <- data_reactive
      private$state_list <- reactiveVal()

      logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
      invisible(self)
    },

    #' @description
    #' Returns a formatted string representing this `FilterStates` object.
    #'
    #' @param show_all (`logical(1)`) passed to `format.teal_slices`
    #' @param trim_lines (`logical(1)`) passed to `format.teal_slices`
    #'
    #' @return `character(1)` the formatted string
    #'
    format = function(show_all = FALSE, trim_lines = TRUE) {
      sprintf(
        "%s:\n%s",
        class(self)[1],
        format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)
      )
    },

    #' @description
    #' Filter call
    #'
    #' Builds *subset expression* from condition calls generated by `FilterState`.
    #' The `lhs` of the expression is a `dataname_prefixed`, where word prefixed refers to
    #' situation when call is evaluated on elements of the original data, for example `dataname[[x]]`.
    #' By default `dataname_prefixed = dataname` and it's not alterable through class methods.
    #' Customization of `private$dataname_prefixed` is done through inheriting classes.
    #'
    #' The `rhs` is a call to `private$fun` with following arguments:
    #' - `dataname_prefixed`
    #' - list of logical expressions generated by `FilterState` objects
    #' stored in `private$state_list`. Each logical predicate is combined with `&` operator.
    #' Variables in these logical expressions by default are not prefixed but this can be changed
    #' by setting `private$extract_type` (change in the similar way as `dataname_prefixed`)
    #' Possible call outputs depending on a custom fields/options:
    #' ```
    #' # default
    #' dataname <- subset(dataname, col == "x")
    #'
    #' # fun = dplyr::filter
    #' dataname <- dplyr::filter(dataname, col == "x")
    #'
    #' # fun = MultiAssayExperiment::subsetByColData; extract_type = "list"
    #' dataname <- MultiAssayExperiment::subsetByColData(dataname, dataname$col == "x")
    #'
    #' # teal_slice objects having `arg = "subset"` and `arg = "select"`
    #' dataname <- subset(dataname, subset = row_col == "x", select = col_col == "x")
    #'
    #' # dataname = dataname[[element]]
    #' dataname[[element]] <- subset(dataname[[element]], subset = col == "x")
    #' ```
    #'
    #' If no filters are applied, `NULL` is returned to avoid no-op calls such as `dataname <- dataname`.
    #'
    #' @param sid (`character`)
    #'  when specified then method returns code containing condition calls (logical predicates) of
    #'  `FilterState` objects which `"sid"` attribute is different than this `sid` argument.
    #'
    #' @return `call` or `NULL`
    #'
    get_call = function(sid = "") {
      logger::log_trace("FilterStates$get_call initializing")

      # `arg` must be the same as argument of the function where
      # predicate is passed to.
      # For unnamed arguments state_list should have `arg = NULL`
      states_list <- private$state_list_get()
      if (length(states_list) == 0) {
        return(NULL)
      }
      args <- vapply(
        states_list,
        function(x) {
          arg <- x$get_state()$arg
          `if`(is.null(arg), "", arg) # converting NULL -> "" to enable tapply.
        },
        character(1)
      )

      filter_items <- tapply(
        X = states_list,
        INDEX = args,
        simplify = FALSE,
        function(items) {
          # removing filters identified by sid
          other_filter_idx <- !names(items) %in% sid
          filtered_items <- items[other_filter_idx]

          calls <- Filter(
            Negate(is.null),
            lapply(
              filtered_items,
              function(state) {
                state$get_call(dataname = private$dataname_prefixed)
              }
            )
          )
          calls_combine_by(calls, operator = "&")
        }
      )
      filter_items <- Filter(
        x = filter_items,
        f = Negate(is.null)
      )
      if (length(filter_items) > 0L) {
        filter_function <- private$fun
        data_name <- str2lang(private$dataname_prefixed)
        substitute(
          env = list(
            lhs = data_name,
            rhs = as.call(c(filter_function, c(list(data_name), filter_items)))
          ),
          expr = lhs <- rhs
        )
      } else {
        # return NULL to avoid no-op call
        NULL
      }
    },

    #' @description
    #' Prints this `FilterStates` object.
    #'
    #' @param ... additional arguments passed to `format`.
    print = function(...) {
      cat(isolate(self$format(...)), "\n")
    },

    #' @description
    #' Remove one or more `FilterState`s from the `state_list` along with their UI elements.
    #'
    #' @param state (`teal_slices`)
    #'   specifying `FilterState` objects to remove;
    #'   `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored
    #'
    #' @return `NULL`, invisibly.
    #'
    remove_filter_state = function(state) {
      checkmate::assert_class(state, "teal_slices")
      isolate({
        state_ids <- vapply(state, `[[`, character(1), "id")
        logger::log_trace("{ class(self)[1] }$remove_filter_state removing filters, state_id: { toString(state_ids) }")
        private$state_list_remove(state_ids)
      })
      invisible(NULL)
    },

    #' @description
    #' Gets reactive values from active `FilterState` objects.
    #'
    #' Get active filter state from `FilterState` objects stored in `state_list`(s).
    #' The output is a list compatible with input to `self$set_filter_state`.
    #'
    #' @return Object of class `teal_slices`.
    #'
    get_filter_state = function() {
      slices <- unname(lapply(private$state_list(), function(x) x$get_state()))
      fs <- do.call(teal_slices, c(slices, list(count_type = private$count_type)))

      include_varnames <- private$include_varnames
      if (length(include_varnames)) {
        attr(fs, "include_varnames") <- structure(
          list(include_varnames),
          names = private$dataname
        )
      }

      exclude_varnames <- private$exclude_varnames
      if (length(exclude_varnames)) {
        attr(fs, "exclude_varnames") <- structure(
          list(exclude_varnames),
          names = private$dataname
        )
      }

      fs
    },

    #' @description
    #' Sets active `FilterState` objects.
    #' @param state (`teal_slices`)
    #' @return Function that raises an error.
    set_filter_state = function(state) {
      isolate({
        logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(x) {
          checkmate::assert_true(
            x$dataname == private$dataname,
            .var.name = "dataname matches private$dataname"
          )
        })

        private$set_filterable_varnames(
          include_varnames = attr(state, "include_varnames")[[private$dataname]],
          exclude_varnames = attr(state, "exclude_varnames")[[private$dataname]]
        )
        count_type <- attr(state, "count_type")
        if (length(count_type)) {
          private$count_type <- count_type
        }

        # Drop teal_slices that refer to excluded variables.
        varnames <- unique(unlist(lapply(state, "[[", "varname")))
        excluded_varnames <- setdiff(varnames, private$get_filterable_varnames())
        if (length(excluded_varnames)) {
          state <- Filter(function(x) !isTRUE(x$varname %in% excluded_varnames), state)
          warning(sprintf("filters for columns: %s excluded from %s", toString(excluded_varnames), private$dataname))
        }

        if (length(state) > 0) {
          private$set_filter_state_impl(
            state = state,
            data = private$data,
            data_reactive = private$data_reactive
          )
        }
        logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
      })

      invisible(NULL)
    },

    #' @description
    #' Remove all `FilterState` objects from this `FilterStates` object.
    #'
    #' @param force (`logical(1)`)
    #'   flag specifying whether to include anchored filter states.
    #'
    #' @return `NULL`, invisibly.
    #'
    clear_filter_states = function(force = FALSE) {
      private$state_list_empty(force)
      invisible(NULL)
    },

    # shiny modules ----

    #' @description
    #' `shiny` UI definition that stores `FilterState` UI elements.
    #' Populated with elements created with `renderUI` in the module server.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `shiny.tag`
    #'
    ui_active = function(id) {
      ns <- NS(id)
      tagList(
        include_css_files(pattern = "filter-panel"),
        uiOutput(ns("trigger_visible_state_change"), inline = TRUE),
        uiOutput(
          ns("cards"),
          class = "accordion",
          `data-label` = ifelse(length(private$datalabel), paste0("> ", private$datalabel), ""),
        )
      )
    },

    #' @description
    #' `shiny` server module.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `NULL`.
    #'
    srv_active = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilterState$srv_active initializing, dataname: { private$dataname }")
          current_state <- reactive(private$state_list_get())
          previous_state <- reactiveVal(NULL) # FilterState list
          added_states <- reactiveVal(NULL) # FilterState list

          # gives a valid shiny ns based on a default slice id
          fs_to_shiny_ns <- function(x) {
            checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
            gsub("[^[:alnum:]]+", "_", get_default_slice_id(x$get_state()))
          }

          output$trigger_visible_state_change <- renderUI({
            current_state()
            isolate({
              logger::log_trace("FilterStates$srv_active@1 determining added and removed filter states")
              # Be aware this returns a list because `current_state` is a list and not `teal_slices`.
              added_states(setdiff_teal_slices(current_state(), previous_state()))
              previous_state(current_state())
              NULL
            })
          })

          output[["cards"]] <- renderUI({
            lapply(
              current_state(), # observes only if added/removed
              function(state) {
                isolate( # isolates when existing state changes
                  state$ui(id = session$ns(fs_to_shiny_ns(state)), parent_id = session$ns("cards"))
                )
              }
            )
          })

          observeEvent(
            added_states(), # we want to call FilterState module only once when it's added
            ignoreNULL = TRUE,
            {
              added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L))
              logger::log_trace("FilterStates$srv_active@2 triggered by added states: { toString(added_state_names) }")
              lapply(added_states(), function(state) {
                fs_callback <- state$server(id = fs_to_shiny_ns(state))
                observeEvent(
                  once = TRUE, # remove button can be called once, should be destroyed afterwards
                  ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI
                  eventExpr = fs_callback(), # when remove button is clicked in the FilterState ui
                  handlerExpr = private$state_list_remove(state$get_state()$id)
                )
              })
              added_states(NULL)
            }
          )

          NULL
        }
      )
    },

    #' @description
    #' `shiny` UI module to add filter variable.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `shiny.tag`
    #'
    ui_add = function(id) {
      checkmate::assert_string(id)
      data <- private$data

      ns <- NS(id)

      if (ncol(data) == 0) {
        tags$div("no sample variables available")
      } else if (nrow(data) == 0) {
        tags$div("no samples available")
      } else {
        uiOutput(ns("add_filter"))
      }
    },

    #' @description
    #' `shiny` server module to add filter variable.
    #'
    #' This module controls available choices to select as a filter variable.
    #' Once selected, a variable is removed from available choices.
    #' Removing a filter variable adds it back to available choices.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `NULL`.
    srv_add = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilterStates$srv_add initializing, dataname: { private$dataname }")

          # available choices to display
          avail_column_choices <- reactive({
            data <- private$data
            vars_include <- private$get_filterable_varnames()
            active_filter_vars <- unique(unlist(lapply(self$get_filter_state(), "[[", "varname")))
            choices <- setdiff(vars_include, active_filter_vars)
            varlabels <- get_varlabels(data)

            data_choices_labeled(
              data = data,
              choices = choices,
              varlabels = varlabels,
              keys = private$keys
            )
          })


          output$add_filter <- renderUI({
            logger::log_trace(
              "FilterStates$srv_add@1 updating available column choices, dataname: { private$dataname }"
            )
            if (length(avail_column_choices()) == 0) {
              tags$span("No available columns to add.")
            } else {
              tags$div(
                teal.widgets::optionalSelectInput(
                  session$ns("var_to_add"),
                  choices = avail_column_choices(),
                  selected = NULL,
                  options = shinyWidgets::pickerOptions(
                    liveSearch = TRUE,
                    noneSelectedText = "Select variable to filter"
                  )
                )
              )
            }
          })

          observeEvent(
            eventExpr = input$var_to_add,
            handlerExpr = {
              logger::log_trace(
                sprintf(
                  "FilterStates$srv_add@2 adding FilterState of variable %s, dataname: %s",
                  input$var_to_add,
                  private$dataname
                )
              )
              self$set_filter_state(
                teal_slices(
                  teal_slice(dataname = private$dataname, varname = input$var_to_add)
                )
              )
              logger::log_trace(
                sprintf(
                  "FilterStates$srv_add@2 added FilterState of variable %s, dataname: %s",
                  input$var_to_add,
                  private$dataname
                )
              )
            }
          )

          logger::log_trace("FilterStates$srv_add initialized, dataname: { private$dataname }")
          NULL
        }
      )
    }
  ),
  private = list(
    # private fields ----
    count_type = "none", # specifies how observation numbers are displayed in filter cards,
    data = NULL, # data.frame, MAE, SE or matrix
    data_reactive = NULL, # reactive
    datalabel = NULL, # to follow default `experiment = NULL` in `teal_slice`
    dataname = NULL, # because it holds object of class name
    dataname_prefixed = character(0), # name used in call returned from get_call
    exclude_varnames = character(0), # holds column names
    include_varnames = character(0), # holds column names
    extract_type = character(0), # type of the prefix in a subset call (eg. "list": x$var; "matrix": x[["var"]])
    fun = quote(subset), # function used to generate subset call
    keys = character(0),
    ns = NULL, # shiny ns()
    observers = list(), # observers
    state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes,

    # private methods ----

    # @description
    # Set the allowed filterable variables
    # @param include_varnames (`character`) Names of variables included in filtering.
    # @param exclude_varnames (`character`) Names of variables excluded from filtering.
    #
    # @details When retrieving the filtered variables only
    # those which have filtering supported (i.e. are of the permitted types).
    # Only one from `include_varnames` and `exclude_varnames` can be used in one call. When `exclude_varnames`
    # is called `include_varnames` is cleared - same otherwise.
    # are included.
    #
    # @return `NULL`, invisibly.
    set_filterable_varnames = function(include_varnames = character(0), exclude_varnames = character(0)) {
      if ((length(include_varnames) + length(exclude_varnames)) == 0L) {
        return(invisible(NULL))
      }
      checkmate::assert_character(include_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE)
      checkmate::assert_character(exclude_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE)
      if (length(include_varnames) && length(exclude_varnames)) {
        stop(
          "`include_varnames` and `exclude_varnames` has been both specified for",
          private$dataname,
          ". Only one per dataset is allowed.",
        )
      }
      supported_vars <- get_supported_filter_varnames(private$data)
      if (length(include_varnames)) {
        private$include_varnames <- intersect(include_varnames, supported_vars)
        private$exclude_varnames <- character(0)
      } else {
        private$exclude_varnames <- exclude_varnames
        private$include_varnames <- character(0)
      }
      invisible(NULL)
    },

    # @description
    # Get vector of filterable varnames
    #
    # @details
    #  These are the only columns which can be used in the filter panel
    #
    # @return character vector with names of the columns
    get_filterable_varnames = function() {
      if (length(private$include_varnames)) {
        private$include_varnames
      } else {
        supported_varnames <- get_supported_filter_varnames(private$data)
        setdiff(supported_varnames, private$exclude_varnames)
      }
    },

    # state_list methods ----

    # @description
    # Returns a list of `FilterState` objects stored in this `FilterStates`.
    #
    # @param state_id (`character(1)`)
    #   name of element in a filter state (which is a `reactiveVal` containing a list)
    #
    # @return `list` of `FilterState` objects
    #
    state_list_get = function(state_id = NULL) {
      checkmate::assert_string(state_id, null.ok = TRUE)

      if (is.null(state_id)) {
        private$state_list()
      } else {
        private$state_list()[[state_id]]
      }
    },

    # @description
    # Adds a new `FilterState` object to this `FilterStates`.
    # Raises error if the length of `x` does not match the length of `state_id`.
    #
    # @param x (`FilterState`)
    #   object to be added to filter state list
    # @param state_id (`character(1)`)
    #   name of element in a filter state (which is a `reactiveVal` containing a list)
    #
    # @return `NULL`.
    #
    state_list_push = function(x, state_id) {
      logger::log_trace("{ class(self)[1] } pushing into state_list, dataname: { private$dataname }")
      checkmate::assert_string(state_id)
      checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
      state <- stats::setNames(list(x), state_id)
      new_state_list <- c(
        isolate(private$state_list()),
        state
      )
      isolate(private$state_list(new_state_list))

      logger::log_trace("{ class(self)[1] } pushed into queue, dataname: { private$dataname }")
      invisible(NULL)
    },

    # @description
    # Removes a single filter state with all associated shiny elements:
    # * specified `FilterState` from `private$state_list`
    # * UI card created for this filter
    # * observers tracking the selection and remove button
    #
    # @param state_id (`character`)
    #   identifiers of elements in a filter state (which is a `reactiveVal` containing a list).
    # @param force (`logical(1)`)
    #   flag specifying whether to include anchored filter states.
    #
    # @return `NULL`, invisibly.
    #
    state_list_remove = function(state_id, force = FALSE) {
      checkmate::assert_character(state_id)
      logger::log_trace("{ class(self)[1] } removing a filter, state_id: { toString(state_id) }")

      isolate({
        current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1))
        to_remove <- state_id %in% current_state_ids
        if (any(to_remove)) {
          new_state_list <- Filter(
            function(state) {
              if (state$get_state()$id %in% state_id) {
                if (state$get_state()$anchored && !force) {
                  return(TRUE)
                } else {
                  state$destroy_observers()
                  FALSE
                }
              } else {
                TRUE
              }
            },
            private$state_list()
          )
          private$state_list(new_state_list)
        } else {
          warning(sprintf("\"%s\" not found in state list", state_id))
        }
      })

      invisible(NULL)
    },

    # @description
    # Remove all `FilterState` objects from this `FilterStates` object.
    # @param force (`logical(1)`)
    #   flag specifying whether to include anchored filter states.
    # @return `NULL`, invisibly.
    #
    state_list_empty = function(force = FALSE) {
      isolate({
        logger::log_trace(
          "{ class(self)[1] }$state_list_empty removing all non-anchored filters for dataname: { private$dataname }"
        )

        state_list <- private$state_list()
        if (length(state_list)) {
          state_ids <- vapply(state_list, function(x) x$get_state()$id, character(1))
          private$state_list_remove(state_ids, force)
        }
      })

      invisible(NULL)
    },

    # @description
    # Set filter state
    #
    # Utility method for `set_filter_state` to create or modify `FilterState` using a single
    #  `teal_slice`.
    # @param state (`teal_slices`)
    # @param data (`data.frame`, `matrix` or `DataFrame`)
    # @param data_reactive (`function`)
    #  function having `sid` as argument.
    #
    # @return `NULL`, invisibly.
    #
    set_filter_state_impl = function(state,
                                     data,
                                     data_reactive) {
      checkmate::assert_class(state, "teal_slices")
      checkmate::assert_multi_class(data, c("data.frame", "matrix", "DataFrame", "HermesData"))
      checkmate::assert_function(data_reactive, args = "sid")
      if (length(state) == 0L) {
        return(invisible(NULL))
      }

      slices_hashed <- vapply(state, `[[`, character(1L), "id")
      if (any(duplicated(slices_hashed))) {
        stop(
          "Some of the teal_slice objects refer to the same filter. ",
          "Please specify different 'id' when calling teal_slice"
        )
      }

      state_list <- isolate(private$state_list_get())
      lapply(state, function(slice) {
        state_id <- slice$id
        if (state_id %in% names(state_list)) {
          # Modify existing filter states.
          state_list[[state_id]]$set_state(slice)
        } else {
          if (inherits(slice, "teal_slice_expr")) {
            # create a new FilterStateExpr
            fstate <- init_filter_state_expr(slice)
          } else {
            # create a new FilterState
            fstate <- init_filter_state(
              x = data[, slice$varname, drop = TRUE],
              # data_reactive is a function which eventually calls get_call(sid).
              # This chain of calls returns column from the data filtered by everything
              # but filter identified by the sid argument. FilterState then get x_reactive
              # and this no longer needs to be a function to pass sid. reactive in the FilterState
              # is also beneficial as it can be cached and retriger filter counts only if
              # returned vector is different.
              x_reactive = if (private$count_type == "none") {
                reactive(NULL)
              } else {
                reactive(data_reactive(state_id)[, slice$varname, drop = TRUE])
              },
              slice = slice,
              extract_type = private$extract_type
            )
          }
          private$state_list_push(x = fstate, state_id = state_id)
        }
      })

      invisible(NULL)
    }
  )
)