teal.slice coverage - 69.60%

Files
Source

File	Lines	Relevant	Covered	Missed	Hits / Line	Coverage
R/zzz.R	51	17	0	17	0	0.00%
R/include_css_js.R	17	4	0	4	0	0.00%
R/FilterStateExpr.R	281	63	14	49	2	22.22%
R/FilterStateLogical.R	407	151	45	106	3	29.80%
R/FilterStateDatettime.R	550	240	87	153	5	36.25%
R/FilterStateDate.R	440	168	71	97	6	42.26%
R/FilterStateEmpty.R	172	40	18	22	2	45.00%
R/FilteredDataset.R	501	198	125	73	27	63.13%
R/FilteredData.R	1036	402	265	137	14	65.92%
R/FilterStateChoices.R	622	263	178	85	36	67.68%
R/choices_labeled.R	88	45	31	14	13	68.89%
R/FilteredDatasetMAE.R	254	104	74	30	15	71.15%
R/FilteredData-utils.R	189	43	31	12	8	72.09%
R/FilterStateRange.R	745	330	243	87	23	73.64%
R/FilterStatesSE.R	282	139	105	34	13	75.54%
R/FilteredDatasetDefault.R	124	18	14	4	3	77.78%
R/FilterState.R	798	289	236	53	61	81.66%
R/FilterStates-utils.R	247	60	53	7	56	88.33%
R/FilterStatesMAE.R	61	10	9	1	21	90.00%
R/FilterStates.R	773	283	257	26	76	90.81%
R/FilteredDatasetDataframe.R	279	97	89	8	25	91.75%
R/variable_types.R	58	13	12	1	10	92.31%
R/teal_slices.R	283	78	73	5	327	93.59%
R/FilteredDataset-utils.R	149	20	19	1	42	95.00%
R/teal_slice.R	389	93	89	4	422	95.70%
R/filter_panel_api.R	182	24	23	1	2	95.83%
R/FilterState-utils.R	298	89	87	2	81	97.75%
R/count_labels.R	246	90	90	0	40	100.00%
R/utils.R	117	24	24	0	291	100.00%
R/test_utils.R	41	14	14	0	20	100.00%
R/FilterPanelAPI.R	116	10	10	0	4	100.00%
R/calls_combine_by.R	38	6	6	0	45	100.00%
R/FilterStatesMatrix.R	48	6	6	0	22	100.00%
R/FilterStatesDF.R	199	5	5	0	99	100.00%

# 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_debug("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 <- if (identical(dataname, make.names(dataname))) {
        dataname
      } else {
        sprintf("`%s`", dataname)
      }
      private$data <- data
      private$data_reactive <- data_reactive
      private$state_list <- reactiveVal()

      # Clears state list when finalizing the object
      private$session_bindings[["clear_state_list"]] <- list(
        destroy = function() {
          private$state_list_empty(force = TRUE)
          isolate(private$state_list(NULL))
        }
      )

      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 = "") {
      # `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 <- tryCatch(
          {
            str2lang(private$dataname_prefixed)
          },
          error = function(e) str2lang(paste0("`", 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) {
      isolate({
        logger::log_debug("{ class(self)[1] }$remove_filter_state removing filters, state_id: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        state_ids <- vapply(state, `[[`, character(1L), "id")
        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_debug("{ 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
          )
        }
      })

      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_debug("{ class(self)[1] }$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_debug("{ class(self)[1] }$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"))
                )
              }
            )
          })

          private$session_bindings[[session$ns("added_states")]] <- 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_debug(
                "{ class(self)[1] }$srv_active@2 triggered by added states: { toString(added_state_names) }"
              )
              lapply(added_states(), function(state) {
                state$server(
                  id = fs_to_shiny_ns(state),
                  remove_callback = function() 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_debug("{ class(self)[1] }$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_debug(
              "{ class(self)[1] }$srv_add@1 updating available column choices, dataname: { private$dataname }"
            )
            if (length(avail_column_choices()) == 0) {
              # because input UI is not rendered on this condition but shiny still holds latest selected value
              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"
                  )
                )
              )
            }
          })

          private$session_bindings[[session$ns("var_to_add")]] <- observeEvent(
            eventExpr = input$var_to_add,
            handlerExpr = {
              logger::log_debug(
                "{ class(self)[1] }$srv_add@2 adding FilterState for variable { input$var_to_add }, ",
                "dataname {private$dataname}"
              )
              self$set_filter_state(
                teal_slices(
                  teal_slice(dataname = private$dataname, varname = input$var_to_add)
                )
              )
            }
          )

          # Extra observer that clears all input values in session
          private$session_bindings[[session$ns("inputs")]] <- list(
            destroy = function() {
              lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
            }
          )

          NULL
        }
      )
    },

    #' @description
    #' Object cleanup.
    #'
    #' - Destroy inputs and observers stored in `private$session_bindings`
    #' - Clean `state_list`
    #'
    #' @return `NULL`, invisibly.
    #'
    finalize = function() {
      .finalize_session_bindings(self, private)
      invisible(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()
    session_bindings = list(), # inputs and 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) {
      isolate({
        logger::log_debug("{ class(self)[1] }$state_list_push pushing into state_list, state_id: { state_id }")
        checkmate::assert_string(state_id)
        checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
        state <- stats::setNames(list(x), state_id)
        new_state_list <- c(private$state_list(), state)
        private$state_list(new_state_list)
        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) {
      isolate({
        checkmate::assert_character(state_id)
        logger::log_debug("{ class(self)[1] }$state_list_remove removing a filter, state_id: { toString(state_id) }")
        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) {
                  TRUE
                } else {
                  state$finalize()
                  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_debug(
          "{ 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(1L))
          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) {
      isolate({
        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 <- 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)
      })
    }
  )
)

# FilteredDataset abstract --------

#' @name FilteredDataset
#' @docType class
#'
#' @title `FilteredDataset` `R6` class
#' @description
#' `FilteredDataset` is a class which renders/controls `FilterStates`(s)
#' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one
#' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects.
#' Each `FilterStates` is responsible for one filter/subset expression applied for specific
#' components of the dataset.
#'
#' @keywords internal
FilteredDataset <- R6::R6Class( # nolint
  "FilteredDataset",
  # public methods ----
  public = list(
    #' @description
    #' Initializes this `FilteredDataset` object.
    #'
    #' @param dataset any object
    #' @param dataname (`character(1)`)
    #'  syntactically valid name given to the dataset.
    #' @param keys (`character`) optional
    #'   vector of primary key column names.
    #' @param label (`character(1)`)
    #'   label to describe the dataset.
    #'
    #' @return Object of class `FilteredDataset`, invisibly.
    #'
    initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label", exact = TRUE)) {
      checkmate::assert_string(dataname)
      logger::log_debug("Instantiating { class(self)[1] }, dataname: { dataname }")
      checkmate::assert_character(keys, any.missing = FALSE)
      checkmate::assert_character(label, null.ok = TRUE)
      private$dataset <- dataset
      private$dataname <- dataname
      private$keys <- keys
      private$label <- if (is.null(label)) character(0) else label

      # function executing reactive call and returning data
      private$data_filtered_fun <- function(sid = "") {
        checkmate::assert_character(sid)
        if (length(sid)) {
          logger::log_debug("filtering data dataname: { dataname }, sid: { sid }")
        } else {
          logger::log_debug("filtering data dataname: { dataname }")
        }
        env <- new.env(parent = parent.env(globalenv()))
        env[[dataname]] <- private$dataset
        filter_call <- self$get_call(sid)
        eval_expr_with_msg(filter_call, env)
        get(x = dataname, envir = env)
      }

      private$data_filtered <- reactive(private$data_filtered_fun())
      invisible(self)
    },

    #' @description
    #' Returns a formatted string representing this `FilteredDataset` object.
    #'
    #' @param show_all (`logical(1)`) passed to `format.teal_slice`.
    #' @param trim_lines (`logical(1)`) passed to `format.teal_slice`.
    #'
    #' @return The formatted character 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
    #' Prints this `FilteredDataset` object.
    #'
    #' @param ... additional arguments passed to `format`.
    #'
    print = function(...) {
      cat(isolate(self$format(...)), "\n")
    },

    #' @description
    #' Removes all filter items applied to this dataset.
    #'
    #' @param force (`logical(1)`)
    #'   flag specifying whether to include anchored filter states.
    #'
    #' @return `NULL`.
    clear_filter_states = function(force = FALSE) {
      logger::log_debug("Removing filters from FilteredDataset: { private$dataname }")
      lapply(
        private$get_filter_states(),
        function(filter_states) filter_states$clear_filter_states(force)
      )
      NULL
    },

    # managing filter states -----

    # getters ----
    #' @description
    #' Gets a filter expression.
    #'
    #' This function returns filter calls equivalent to selected items
    #' within each of `filter_states`. Configuration of the calls is constant and
    #' depends on `filter_states` type and order which are set during initialization.
    #'
    #' @param sid (`character`)
    #'  when specified, the method returns code containing conditions calls of
    #'  `FilterState` objects with `sid` different to this `sid` argument.
    #'
    #' @return Either a `list` of filter `call`s, or `NULL`.
    get_call = function(sid = "") {
      filter_call <- Filter(
        f = Negate(is.null),
        x = lapply(private$get_filter_states(), function(x) x$get_call(sid))
      )
      if (length(filter_call) == 0) {
        return(NULL)
      }
      filter_call
    },

    #' @description
    #' Gets states of all contained `FilterState` objects.
    #'
    #' @return A `teal_slices` object.
    #'
    get_filter_state = function() {
      states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state()))
      do.call(c, states)
    },

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #'
    #' @return Virtual method, returns nothing and raises error.
    #'
    set_filter_state = function(state) {
      stop("set_filter_state is an abstract class method.")
    },

    #' @description
    #' Gets the name of the dataset.
    #'
    #' @return A character string.
    get_dataname = function() {
      private$dataname
    },

    #' @description
    #' Gets the dataset object in this `FilteredDataset`.
    #'
    #' @param filtered (`logical(1)`)
    #'
    #' @return
    #' The stored dataset. If `data.frame` or `MultiAssayExperiment`,
    #' either raw or as a reactive with current filters applied (depending on `filtered`).
    #'
    get_dataset = function(filtered = FALSE) {
      if (filtered) {
        private$data_filtered
      } else {
        private$dataset
      }
    },

    #' @description
    #' Get filter overview of a dataset.
    #' @return Virtual method, returns nothing and raises an error.
    get_filter_overview = function() {
      stop("get_filter_overview is an abstract class method")
    },

    #' @description
    #' Gets the key columns for this dataset.
    #' @return Character vector of variable names
    get_keys = function() {
      private$keys
    },

    #' @description
    #' Gets the dataset label.
    #' @return Character string.
    get_dataset_label = function() {
      private$label
    },

    # modules ------
    #' @description
    #' `shiny` module containing active filters for a dataset, along with a title and a remove button.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param allow_add (`logical(1)`)
    #'   logical flag specifying whether the user will be able to add new filters
    #'
    #' @return `shiny.tag`
    ui_active = function(id, allow_add = TRUE) {
      dataname <- self$get_dataname()
      checkmate::assert_string(dataname)

      ns <- NS(id)
      if_multiple_filter_states <- length(private$get_filter_states()) > 1
      tags$span(
        id = id,
        class = "teal-slice",
        include_css_files("filter-panel"),
        include_js_files(pattern = "icons"),
        bslib::accordion(
          id = ns("dataset_filter_accordian"),
          class = "teal-slice-dataset-filter",
          bslib::accordion_panel(
            dataname,
            style = "padding: 0; margin: 0;",
            bslib::page_fluid(
              id = ns("whole_ui"),
              style = "margin: 0; padding: 0;",
              uiOutput(ns("active_filter_badge")),
              div(
                id = ns("filter_util_icons"),
                class = "teal-slice filter-util-icons",
                if (allow_add) {
                  tags$a(
                    class = "teal-slice filter-icon",
                    tags$i(
                      id = ns("add_filter_icon"),
                      class = "fa fa-plus",
                      title = "fold/expand transform panel",
                      onclick = sprintf(
                        "togglePanelItems(this, '%s', 'fa-plus', 'fa-minus');
                        if ($(this).hasClass('fa-minus')) {
                          $('#%s .accordion-button.collapsed').click();
                        }",
                        ns("add_panel"),
                        ns("dataset_filter_accordian")
                      )
                    )
                  )
                },
                uiOutput(ns("remove_filters_ui"))
              ),
              bslib::page_fluid(
                style = "padding: 0px 15px 0px 15px; margin: 0;",
                if (allow_add) {
                  tags$div(
                    id = ns("add_panel"),
                    class = "add-panel",
                    style = "display: none;",
                    self$ui_add(ns(private$dataname))
                  )
                }
              ),
              tags$div(
                id = ns("filter_count_ui"),
                style = "display: none;",
                tagList(
                  textOutput(ns("filter_count"))
                )
              ),
              tags$div(
                # id needed to insert and remove UI to filter single variable as needed
                # it is currently also used by the above module to entirely hide this panel
                id = ns("filters"),
                class = "parent-hideable-list-group",
                tagList(
                  lapply(
                    names(private$get_filter_states()),
                    function(x) {
                      tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x)))
                    }
                  )
                )
              )
            )
          )
        ),
        tags$script(
          HTML(
            sprintf(
              "
            $(document).ready(function() {
              $('#%s').appendTo('#%s > .accordion-item > .accordion-header');
              $('#%s > .accordion-item > .accordion-header').css({
                'display': 'flex'
              });
              $('#%s').appendTo('#%s .accordion-header .accordion-title');
            });
          ",
              ns("filter_util_icons"),
              ns("dataset_filter_accordian"),
              ns("dataset_filter_accordian"),
              ns("active_filter_badge"),
              ns("dataset_filter_accordian")
            )
          )
        )
      )
    },

    #' @description
    #' Server module for a dataset active filters.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `NULL`.
    srv_active = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          dataname <- self$get_dataname()
          logger::log_debug("FilteredDataset$srv_active initializing, dataname: { dataname }")
          checkmate::assert_string(dataname)

          filter_count <- reactive({
            length(self$get_filter_state())
          })

          output$active_filter_badge <- renderUI({
            if (filter_count() == 0) {
              return(NULL)
            }
            tags$span(
              filter_count(),
              class = "teal-slice data-filter-badge-count"
            )
          })

          output$filter_count <- renderText(
            sprintf(
              "%d filter%s applied",
              filter_count(),
              if (filter_count() != 1) "s" else ""
            )
          )

          lapply(
            names(private$get_filter_states()),
            function(x) {
              private$get_filter_states()[[x]]$srv_active(id = x)
            }
          )

          is_filter_removable <- reactive({
            non_anchored <- Filter(function(x) !x$anchored, self$get_filter_state())
            isTRUE(length(non_anchored) > 0)
          })

          private$session_bindings[[session$ns("get_filter_state")]] <- observeEvent(
            self$get_filter_state(),
            ignoreInit = TRUE,
            {
              shinyjs::hide("filter_count_ui")
              shinyjs::show("filters")
              shinyjs::toggle("remove_filters_ui", condition = is_filter_removable())
              shinyjs::runjs(
                sprintf(
                  "setAndRemoveClass('#%s', 'fa-angle-down', 'fa-angle-right')",
                  session$ns("collapse_icon")
                )
              )
            }
          )

          output$remove_filters_ui <- renderUI({
            req(is_filter_removable())
            tags$div(
              style = "display: flex;",
              actionLink(
                session$ns("remove_filters"),
                label = "",
                icon = icon("far fa-circle-xmark"),
                class = "teal-slice filter-icon"
              )
            )
          })

          # If the accordion input is `NULL` it is being collapsed.
          # It has the accordion panel label if it is expanded.
          observeEvent(input$dataset_filter_accordian, ignoreNULL = FALSE, {
            if (is.null(input$dataset_filter_accordian)) {
              # Hiding the `add_panel` dropdown and changing the minus icon to plus
              # TODO: simplify this implementation. This is done in multiple places
              shinyjs::runjs(
                sprintf(
                  "var element = $('#%s.fa-minus');
                  if (element.length) {
                      element.click();
                      $('#%s').hide();
                  }",
                  session$ns("add_filter_icon"),
                  session$ns("add_panel")
                )
              )
            }
          })

          private$session_bindings[[session$ns("remove_filters")]] <- observeEvent(input$remove_filters, {
            logger::log_debug("FilteredDataset$srv_active@1 removing all non-anchored filters, dataname: { dataname }")
            self$clear_filter_states()
          })

          private$session_bindings[[session$ns("inputs")]] <- list(
            destroy = function() {
              lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
            }
          )

          self$srv_add(private$dataname)

          NULL
        }
      )
    },

    #' @description
    #' UI module to add filter variable for this dataset.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return Virtual method, returns nothing and raises error.
    ui_add = function(id) {
      stop("Pure virtual method")
    },

    #' @description
    #' Server module to add filter variable for this dataset.
    #' For this class `srv_add` calls multiple modules
    #' of the same name from `FilterStates` as `MAEFilteredDataset`
    #' contains one `FilterStates` object for `colData` and one for each experiment.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `NULL`.
    srv_add = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("FilteredDataset$srv_add initializing, dataname: { private$dataname }")
          elems <- private$get_filter_states()
          elem_names <- names(private$get_filter_states())
          lapply(
            elem_names,
            function(elem_name) elems[[elem_name]]$srv_add(elem_name)
          )

          NULL
        }
      )
    },

    #' @description
    #' Object and dependencies cleanup.
    #'
    #' - Destroy inputs and observers stored in `private$session_bindings`
    #' - Finalize `FilterStates` stored in `private$filter_states`
    #'
    #' @return `NULL`, invisibly.
    finalize = function() {
      .finalize_session_bindings(self, private)
      lapply(private$filter_states, function(x) x$finalize())
      invisible(NULL)
    }
  ),
  # private fields ----
  private = list(
    dataset = NULL, # data.frame or MultiAssayExperiment
    data_filtered = NULL,
    data_filtered_fun = NULL, # function
    filter_states = list(),
    dataname = character(0),
    keys = character(0),
    label = character(0),
    session_bindings = list(),

    # Adds `FilterStates` to the `private$filter_states`.
    # `FilterStates` is added once for each element of the dataset.
    # @param filter_states (`FilterStates`)
    # @param id (`character(1)`)
    add_filter_states = function(filter_states, id) {
      checkmate::assert_class(filter_states, "FilterStates")
      checkmate::assert_string(id)
      x <- stats::setNames(list(filter_states), id)
      private$filter_states <- c(private$get_filter_states(), x)
    },

    # @description
    # Gets `FilterStates` objects in this `FilteredDataset`.
    # @return list of `FilterStates` objects.
    get_filter_states = function() {
      private$filter_states
    }
  )
)

#' Complete filter specification
#'
#' Create `teal_slices` object to package multiple filters and additional settings.
#' Check out [`teal_slices-utilities`] functions for working with `teal_slices` object.
#'
#' `teal_slices()` collates multiple `teal_slice` objects into a `teal_slices` object,
#' a complete filter specification. This is used by all classes above `FilterState`
#' as well as `filter_panel_api` wrapper functions.
#' `teal_slices` has attributes that modify the behavior of the filter panel, which are resolved by different classes.
#'
#' `include_varnames` and `exclude_varnames` determine which variables can have filters assigned.
#' The former enumerates allowed variables, the latter enumerates forbidden values.
#' Since these could be mutually exclusive, it is impossible to set both allowed and forbidden
#' variables for one data set in one `teal_slices`.
#'
#' @param ... any number of `teal_slice` objects.
#' @param include_varnames,exclude_varnames (`named list`s of `character`) where list names
#'  match names of data sets and vector elements match variable names in respective data sets;
#'  specify which variables are allowed to be filtered; see `Details`.
#' @param count_type `r lifecycle::badge("experimental")`
#' _This is a new feature. Do kindly share your opinions on
#' [`teal.slice`'s GitHub repository](https://github.com/insightsengineering/teal.slice/)._
#'
#'  (`character(1)`) string specifying how observations are tallied by these filter states.
#'  Possible options:
#'  - `"none"` (default) to have counts of single `FilterState` to show unfiltered number only.
#'  - `"all"` to have counts of single `FilterState` to show number of observation in filtered
#'   and unfiltered dataset. Note, that issues were reported when using this option with `MultiAssayExperiment`.
#'   Please make sure that adding new filters doesn't fail on target platform before deploying for production.
#' @param allow_add (`logical(1)`) logical flag specifying whether the user will be able to add new filters
#'
#' @return
#' `teal_slices`, which is an unnamed list of `teal_slice` objects.
#'
#' @examples
#' filter_1 <- teal_slice(
#'   dataname = "dataname1",
#'   varname = "varname1",
#'   choices = letters,
#'   selected = "b",
#'   keep_na = TRUE,
#'   fixed = FALSE,
#'   extra1 = "extraone"
#' )
#' filter_2 <- teal_slice(
#'   dataname = "dataname1",
#'   varname = "varname2",
#'   choices = 1:10,
#'   keep_na = TRUE,
#'   selected = 2,
#'   fixed = TRUE,
#'   anchored = FALSE,
#'   extra2 = "extratwo"
#' )
#' filter_3 <- teal_slice(
#'   dataname = "dataname2",
#'   varname = "varname3",
#'   choices = 1:10 / 10,
#'   keep_na = TRUE,
#'   selected = 0.2,
#'   fixed = TRUE,
#'   anchored = FALSE,
#'   extra1 = "extraone",
#'   extra2 = "extratwo"
#' )
#'
#' all_filters <- teal_slices(
#'   filter_1,
#'   filter_2,
#'   filter_3,
#'   exclude_varnames = list(
#'     "dataname1" = "varname2"
#'   )
#' )
#'
#' is.teal_slices(all_filters)
#' all_filters[1:2]
#' c(all_filters[1], all_filters[2])
#' print(all_filters)
#' print(all_filters, trim_lines = FALSE)
#'
#' @seealso
#' - [`teal_slice`] for creating constituent elements of `teal_slices`
#' - `teal::slices_store` for robust utilities for saving and loading `teal_slices` in `JSON` format
#' - [`is.teal_slices`], [`as.teal_slices`], [`as.list.teal_slices`], [`[.teal_slices`], [`c.teal_slices`]
#' [`print.teal_slices`], [`format.teal_slices`]
#'
#' @export
#'
teal_slices <- function(...,
                        exclude_varnames = NULL,
                        include_varnames = NULL,
                        count_type = NULL,
                        allow_add = TRUE) {
  slices <- list(...)
  checkmate::assert_list(slices, types = "teal_slice", any.missing = FALSE)
  slices_id <- isolate(vapply(slices, `[[`, character(1L), "id"))
  if (any(duplicated(slices_id))) {
    stop(
      "Some teal_slice objects have the same id:\n",
      toString(unique(slices_id[duplicated(slices_id)]))
    )
  }
  checkmate::assert_list(exclude_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)
  checkmate::assert_list(include_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)
  checkmate::assert_character(count_type, len = 1, null.ok = TRUE)
  checkmate::assert_subset(count_type, choices = c("all", "none"), empty.ok = TRUE)
  checkmate::assert_logical(allow_add)

  duplicated_datasets <- intersect(names(include_varnames), names(exclude_varnames))
  if (length(duplicated_datasets)) {
    stop(
      "Some datasets are specified in both, include_varnames and exclude_varnames:\n",
      toString(duplicated_datasets)
    )
  }

  structure(
    slices,
    exclude_varnames = exclude_varnames,
    include_varnames = include_varnames,
    count_type = count_type,
    allow_add = allow_add,
    class = c("teal_slices", class(slices))
  )
}

#' `teal_slices` utility functions
#'
#' Helper functions for working with [`teal_slices`] object.
#' @param x object to test for `teal_slices`, object to convert to `teal_slices` or a `teal_slices` object
#' @param i (`character` or `numeric` or `logical`) indicating which elements to extract
#' @param recursive (`logical(1)`) flag specifying whether to also convert to list the elements of this `teal_slices`
#' @param ... additional arguments passed to other functions.
#' @name teal_slices-utilities
#' @inherit teal_slices examples
#' @keywords internal

#' @rdname teal_slices-utilities
#' @export
#'
is.teal_slices <- function(x) { # nolint
  inherits(x, "teal_slices")
}

#' @rdname teal_slices-utilities
#' @export
#'
as.teal_slices <- function(x) { # nolint
  checkmate::assert_list(x)
  lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")

  attrs <- attributes(unclass(x))
  ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))
  do.call(teal_slices, c(ans, attrs))
}


#' @rdname teal_slices-utilities
#' @export
#'
as.list.teal_slices <- function(x, recursive = FALSE, ...) { # nolint
  ans <- unclass(x)
  if (recursive) ans[] <- lapply(ans, as.list)
  ans
}


#' @rdname teal_slices-utilities
#' @export
#'
`[.teal_slices` <- function(x, i) {
  if (missing(i)) i <- seq_along(x)
  if (length(i) == 0L) {
    return(x[0])
  }
  if (is.logical(i) && length(i) > length(x)) stop("subscript out of bounds")
  if (is.numeric(i) && max(i) > length(x)) stop("subscript out of bounds")
  if (is.character(i)) {
    if (!all(is.element(i, names(x)))) stop("subscript out of bounds")
    i <- which(is.element(i, names(x)))
  }

  y <- NextMethod("[")
  attrs <- attributes(x)
  attrs$names <- attrs$names[i]
  attributes(y) <- attrs
  y
}


#' @rdname teal_slices-utilities
#' @export
#'
c.teal_slices <- function(...) {
  x <- list(...)
  checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")

  all_attributes <- lapply(x, attributes)
  all_attributes <- coalesce_r(all_attributes)
  all_attributes <- all_attributes[names(all_attributes) != "class"]

  do.call(
    teal_slices,
    c(
      unique(unlist(x, recursive = FALSE)),
      all_attributes
    )
  )
}


#' @rdname teal_slices-utilities
#' @param show_all (`logical(1)`) whether to display non-null elements of constituent `teal_slice` objects
#' @param trim_lines (`logical(1)`) whether to trim lines
#' @export
#'
format.teal_slices <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
  checkmate::assert_flag(show_all)
  checkmate::assert_flag(trim_lines)

  x <- as.list(x, recursive = TRUE)
  attrs <- attributes(x)
  attributes(x) <- NULL
  slices_list <- list(slices = x, attributes = attrs)
  slices_list <- Filter(Negate(is.null), slices_list) # drop attributes if empty

  if (!show_all) slices_list$slices <- lapply(slices_list$slices, function(slice) Filter(Negate(is.null), slice))

  jsonify(slices_list, trim_lines)
}

#' @rdname teal_slices-utilities
#' @export
#'
print.teal_slices <- function(x, ...) {
  cat(format(x, ...), "\n")
  invisible(x)
}


#' `setdiff` method for `teal_slices`
#'
#' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`.
#' @param x,y (`teal_slices`)
#' @return `teal_slices`
#' @keywords internal
#'
setdiff_teal_slices <- function(x, y) {
  Filter(
    function(xx) {
      !any(vapply(y, function(yy) identical(yy, xx), logical(1)))
    },
    x
  )
}

#' Recursively coalesce list elements.
#'
#' Returns first element of list that it not `NULL`, recursively.
#'
#' Given a list of atomic vectors, the first non-null element is returned.
#' Given a list of lists, for all `names` found in all elements of the list
#' the first non-null element of a given name is returned.
#'
#' This function is used internally in `c.teal_slices` to manage `teal_slices` attributes.
#'
#' @param x (`list`), either of atomic vectors or of named lists
#' @return
#' Either an atomic vector of length 1 or a (potentially nested) list.
#'
#' @keywords internal
#'
coalesce_r <- function(x) {
  checkmate::assert_list(x)
  xnn <- Filter(Negate(is.null), x)
  if (all(vapply(xnn, is.atomic, logical(1L)))) {
    return(xnn[[1L]])
  }
  lapply(x, checkmate::assert_list, names = "named", null.ok = TRUE, .var.name = "list element")
  all_names <- unique(unlist(lapply(x, names)))
  sapply(all_names, function(nm) coalesce_r(lapply(x, `[[`, nm)), simplify = FALSE)
}

# FilterState ------

#' @name FilterState
#' @docType class
#'
#' @title `FilterState` abstract class
#'
#' @description Abstract class to encapsulate single filter state.
#'
#' @details
#' This class is responsible for managing a single filter item within a `FilteredData` object
#' and outputs a condition call (logical predicate) for subsetting one variable.
#' Filter states depend on the variable type:
#' (`logical`, `integer`, `numeric`, `character`, `factor`, `Date`, `POSIXct`, `POSIXlt`)
#' and `FilterState` subclasses exist that correspond to those types.
#' - `logical`: `class = LogicalFilterState`
#' - `integer`: `class = RangeFilterState`
#' - `numeric`: `class = RangeFilterState`
#' - `character`: `class = ChoicesFilterState`
#' - `factor`: `class = ChoicesFilterState`
#' - `Date`: `class = DateFilterState`
#' - `POSIXct`, `POSIXlt`: `class = DatetimeFilterState`
#' - all `NA` entries: `class: FilterState`, cannot be filtered
#' - default: `FilterState`, cannot be filtered
#'
#' Each variable's filter state is an `R6` object keeps the variable that is filtered,
#' a `teal_slice` object that describes the filter state, as well as a `shiny` module (UI and server)
#' that allows the user to alter the filter state.
#' Changes to the filter state that cause some observations to be omitted
#' trigger the `get_call` method and every `R` function call up in the reactive chain.
#'
#' @section Modifying state:
#' Modifying a `FilterState` object is possible in three scenarios:
#' - In an interactive session, by passing an appropriate `teal_slice` to the `set_state` method.
#' - In a running application, by changing appropriate inputs.
#' - In a running application, by using [filter_state_api] which directly uses
#' `set_state` method of the `FilterState` object.
#'
#' @keywords internal
#'
FilterState <- R6::R6Class( # nolint
  "FilterState",

  # public methods ----
  public = list(

    #' @description
    #' Initialize a `FilterState` object.
    #'
    #' @param x (`vector`)
    #'   variable to be filtered.
    #' @param x_reactive (`reactive`)
    #'   returning vector of the same type as `x`. Is used to update
    #'   counts following the change in values of the filtered dataset.
    #'   If it is set to `reactive(NULL)` then counts based on filtered
    #'   dataset are not shown.
    #' @param slice (`teal_slice`)
    #'   specification of this filter state.
    #'   `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
    #'   `get_state` returns `teal_slice` object which can be reused in other places.
    #'   Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
    #'   changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
    #' @param extract_type (`character`)
    #'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
    #' - `character(0)` (default) `varname` in the condition call will not be prefixed
    #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
    #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
    #'
    #' @return Object of class `FilterState`, invisibly.
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          slice,
                          extract_type = character(0)) {
      isolate({
        checkmate::assert_class(x_reactive, "reactive")
        checkmate::assert_class(slice, "teal_slice")
        checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)
        if (length(extract_type) == 1) {
          checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
        }
        logger::log_debug("{ class(self)[1] } initializing for slice: { slice$id }")

        # Set data properties.
        private$x <- x
        private$x_reactive <- x_reactive
        # Set derived data properties.
        private$na_count <- sum(is.na(x))
        private$filtered_na_count <- reactive(
          if (!is.null(private$x_reactive())) {
            sum(is.na(private$x_reactive()))
          }
        )
        # Set extract type.
        private$extract_type <- extract_type

        # Set state properties.
        if (is.null(isolate(slice$keep_na)) && anyNA(x)) slice$keep_na <- TRUE
        private$teal_slice <- slice
        # Obtain variable label.
        varlabel <- attr(x, "label", exact = TRUE)
        # Display only when different from varname.
        private$varlabel <-
          if (is.null(varlabel) || identical(varlabel, private$get_varname())) {
            character(0)
          } else {
            varlabel
          }

        private$state_history <- reactiveVal(list())

        invisible(self)
      })
    },

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

    #' @description
    #' Prints this `FilterState` object.
    #'
    #' @param ... additional arguments
    #'
    print = function(...) {
      cat(isolate(self$format(...)))
    },

    #' @description
    #' Sets mutable parameters of the filter state.
    #' - `fixed` state is prevented from changing state
    #' - `anchored` state is prevented from removing state
    #'
    #' @param state (`teal_slice`)
    #'
    #' @return `self` invisibly
    #'
    set_state = function(state) {
      if (identical(state, private$slice)) {
        return(self)
      }
      isolate({
        checkmate::assert_class(state, "teal_slice")
        if (private$is_fixed()) {
          warning("attempt to set state on fixed filter aborted id: ", private$get_id())
        } else {
          logger::log_debug("{ class(self)[1] }$set_state setting state of filter id: { private$get_id() }")
          if (!is.null(state$selected)) {
            private$set_selected(state$selected)
          }
          if (!is.null(state$keep_na)) {
            private$set_keep_na(state$keep_na)
          }
          if (!is.null(state$keep_inf)) {
            private$set_keep_inf(state$keep_inf)
          }
          current_state <- sprintf(
            "selected: %s; keep_na: %s; keep_inf: %s",
            toString(private$get_selected()),
            private$get_keep_na(),
            private$get_keep_inf()
          )
        }

        invisible(self)
      })
    },


    #' @description
    #' Returns a complete description of the filter state.
    #'
    #' @return A `teal_slice` object.
    #'
    get_state = function() {
      private$teal_slice
    },

    #' @description
    #' Returns reproducible condition call for current selection relevant
    #' for selected variable type.
    #' Method is using internal reactive values which makes it reactive
    #' and must be executed in reactive or isolated context.
    #'
    get_call = function() {
      stop("this is a virtual method")
    },

    #' @description
    #' `shiny` module server.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @param remove_callback (`function`)
    #'   callback to handle removal of this `FilterState` object from `state_list`
    #'
    #' @return Reactive expression signaling that remove button has been clicked.
    #'
    server = function(id, remove_callback) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("{ class(self)[1] }$server initializing module for slice: { private$get_id() } ")
          private$server_summary("summary")
          if (private$is_fixed()) {
            private$server_inputs_fixed("inputs")
          } else {
            private$server_inputs("inputs")
          }

          private$session_bindings[[session$ns("state")]] <- observeEvent(
            eventExpr = list(private$get_selected(), private$get_keep_na(), private$get_keep_inf()),
            handlerExpr = {
              current_state <- as.list(self$get_state())
              history <- private$state_history()
              history_update <- c(history, list(current_state))
              private$state_history(history_update)
            }
          )

          private$session_bindings[[session$ns("back")]] <- observeEvent(
            eventExpr = input$back,
            handlerExpr = {
              history <- rev(private$state_history())
              slice <- history[[2L]]
              history_update <- rev(history[-(1:2)])
              private$state_history(history_update)
              self$set_state(as.teal_slice(slice))
            }
          )

          private$session_bindings[[session$ns("reset")]] <- observeEvent(
            eventExpr = input$reset,
            handlerExpr = {
              slice <- private$state_history()[[1L]]
              self$set_state(as.teal_slice(slice))
            }
          )

          # Buttons for rewind/reset are disabled upon change in history to prevent double-clicking.
          # Re-enabling occurs after 100 ms, after they are potentially hidden when no history is present.
          private$session_bindings[[session$ns("state_history")]] <- observeEvent(
            eventExpr = private$state_history(),
            handlerExpr = {
              shinyjs::disable(id = "back")
              shinyjs::disable(id = "reset")
              shinyjs::delay(
                ms = 100,
                expr = {
                  shinyjs::toggleElement(id = "back", condition = length(private$state_history()) > 1L)
                  shinyjs::enable(id = "back")
                }
              )
              shinyjs::delay(
                ms = 100,
                expr = {
                  shinyjs::toggleElement(id = "reset", condition = length(private$state_history()) > 1L)
                  shinyjs::enable(id = "reset")
                }
              )
            }
          )

          private$session_bindings[[session$ns("remove")]] <- 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 = input$remove, # when remove button is clicked in the FilterState ui
            handlerExpr = remove_callback()
          )

          private$session_bindings[[session$ns("inputs")]] <- list(
            destroy = function() {
              logger::log_debug("Destroying { class(self)[1] } inputs and observers; id: { private$get_id() }")
              lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
            }
          )

          private$state_history <- reactiveVal(list())

          NULL
        }
      )
    },

    #' @description
    #' `shiny` UI module.
    #'  The UI for this class contains simple message stating that it is not supported.
    #' @param id (`character(1)`)
    #'  `shiny` module instance id.
    #' @param parent_id (`character(1)`) id of the `FilterStates` card container
    ui = function(id, parent_id = "cards") {
      ns <- NS(id)

      # Filter card consists of header and body, arranged in a single column.
      # Body is hidden and is toggled by clicking on header.
      ## Header consists of title and summary, arranged in a column.
      ### Title consists of conditional icon, varname, conditional varlabel, and controls, arranged in a row.
      ### Summary consists of value and controls, arranged in a row.

      tags$div(
        id = id,
        class = "panel filter-card",
        include_js_files("count-bar-labels.js"),
        tags$div(
          class = "filter-card-header",
          `data-toggle` = "collapse",
          `data-bs-toggle` = "collapse",
          href = paste0("#", ns("body")),
          tags$div(
            class = "filter-card-title",
            if (private$is_anchored() && private$is_fixed()) {
              icon("anchor-lock", class = "filter-card-icon")
            } else if (private$is_anchored() && !private$is_fixed()) {
              icon("anchor", class = "filter-card-icon")
            } else if (!private$is_anchored() && private$is_fixed()) {
              icon("lock", class = "filter-card-icon")
            },
            tags$div(class = "filter-card-varname", tags$strong(private$get_varname())),
            tags$div(class = "filter-card-varlabel", private$get_varlabel()),
            tags$div(
              class = "filter-card-controls",
              # Suppress toggling body when clicking on this div.
              # This is for bootstrap 3 and 4. Causes page to scroll to top, prevented by setting href on buttons.
              onclick = "event.stopPropagation();event.preventDefault();",
              # This is for bootstrap 5.
              `data-bs-toggle` = "collapse",
              `data-bs-target` = NULL,
              if (isFALSE(private$is_fixed())) {
                actionLink(
                  inputId = ns("back"),
                  label = NULL,
                  icon = icon("far fa-circle-arrow-left"),
                  title = "Rewind state",
                  class = "filter-card-back",
                  style = "display: none"
                )
              },
              if (isFALSE(private$is_fixed())) {
                actionLink(
                  inputId = ns("reset"),
                  label = NULL,
                  icon = icon("far fa-circle-arrow-up"),
                  title = "Restore original state",
                  class = "filter-card-back",
                  style = "display: none"
                )
              },
              if (isFALSE(private$is_anchored())) {
                actionLink(
                  inputId = ns("remove"),
                  label = icon("far fa-circle-xmark"),
                  title = "Remove filter asdfasdfaksdfk",
                  class = "teal-slice filter-icon"
                )
              }
            )
          ),
          tags$div(class = "filter-card-summary", private$ui_summary(ns("summary")))
        ),
        tags$div(
          id = ns("body"),
          class = "collapse out",
          `data-parent` = paste0("#", parent_id),
          `data-bs-parent` = paste0("#", parent_id),
          tags$div(
            class = "filter-card-body",
            if (private$is_fixed()) {
              private$ui_inputs_fixed(ns("inputs"))
            } else {
              private$ui_inputs(ns("inputs"))
            }
          )
        )
      )
    },

    #' @description
    #' Destroy inputs and observers stored in `private$session_bindings`.
    #'
    #'
    #' @return `NULL`, invisibly.
    #'
    finalize = function() {
      .finalize_session_bindings(self, private)
      invisible(NULL)
    }
  ),

  # private members ----
  private = list(
    # set by constructor
    x = NULL, # the filtered variable
    x_reactive = NULL, # reactive containing the filtered variable, used for updating counts and histograms
    teal_slice = NULL, # stores all transferable properties of this filter state
    extract_type = character(0), # used by private$get_varname_prefixed
    na_count = integer(0),
    filtered_na_count = NULL, # reactive containing the count of NA in the filtered dataset
    varlabel = character(0), # taken from variable labels in data; displayed in filter cards
    # other
    is_choice_limited = FALSE, # flag whether number of possible choices was limited when specifying filter
    session_bindings = list(), # stores observers and inputs to destroy afterwards
    state_history = NULL, # reactiveVal holding a list storing states this FilterState has had since instantiation

    # private methods ----

    # setters for state features ----

    # @description
    # Set values that can be selected from.
    set_choices = function(choices) {
      stop("this is a virtual method")
    },

    # @description
    # Set selection.
    #
    # @param value (`vector`)
    #   value(s) that come from filter selection; values are set in the
    #   module server after a selection is made in the app interface;
    #   values are stored in `teal_slice$selected` which is reactive;
    #   value types have to be the same as `private$get_choices()`
    #
    # @return `NULL`, invisibly.
    set_selected = function(value) {
      isolate({
        value <- private$cast_and_validate(value)
        value <- private$check_length(value)
        value <- private$remove_out_of_bounds_values(value)
        if (!identical(value, private$teal_slice$selected)) {
          logger::log_debug("{ class(self)[1] }$set_selected setting selection for id: { private$get_id() }")
          private$teal_slice$selected <- value
        }
        invisible(NULL)
      })
    },

    # @description
    # Sets `value` in `private$teal_slice$keep_na`.
    #
    # @param value (`logical(1)`)
    #   corresponding to the state of a checkbox input in the `shiny` interface.
    #
    # @return `NULL`, invisibly.
    #
    set_keep_na = function(value) {
      isolate({
        checkmate::assert_flag(value)
        logger::log_debug("{ class(self)[1] }$set_keep_na sets for filter { private$get_id() } to { value }.")
        if (!identical(value, private$teal_slice$keep_na)) {
          private$teal_slice$keep_na <- value
        }
        invisible(NULL)
      })
    },

    # @description
    # Sets `value` in `private$teal_slice$keep_inf`.
    #
    # @param value (`logical(1)`)
    #   corresponding to the state of a checkbox input in the `shiny` interface.
    #
    # @return `NULL`, invisibly.
    #
    set_keep_inf = function(value) {
      isolate({
        if (!identical(value, private$teal_slice$keep_inf)) {
          checkmate::assert_flag(value)
          logger::log_debug(
            sprintf(
              "%s$set_keep_inf of filter %s set to %s",
              class(self)[1],
              private$get_id(),
              value
            )
          )
          private$teal_slice$keep_inf <- value
        }
        invisible(NULL)
      })
    },

    # getters for state features ----

    # @description
    # Returns dataname.
    # @return `character(1)`
    get_dataname = function() {
      isolate(private$teal_slice$dataname)
    },

    # @description
    # Get variable name.
    # @return `character(1)`
    get_varname = function() {
      isolate(private$teal_slice$varname)
    },

    # @description
    # Get id of the teal_slice.
    # @return `character(1)`
    get_id = function() {
      isolate(private$teal_slice$id)
    },

    # @description
    # Get allowed values from `FilterState`.
    # @return
    # Vector describing the available choices. Return type depends on the `FilterState` subclass.
    get_choices = function() {
      isolate(private$teal_slice$choices)
    },

    # @description
    # Get selected values from `FilterState`.
    # @return
    # Vector describing the current selection. Return type depends on the `FilterState` subclass.
    get_selected = function() {
      private$teal_slice$selected
    },

    # @description
    # Returns current `keep_na` selection.
    # @return `logical(1)`
    get_keep_na = function() {
      private$teal_slice$keep_na
    },

    # @description
    # Returns current `keep_inf` selection.
    # @return (`logical(1)`)
    get_keep_inf = function() {
      private$teal_slice$keep_inf
    },

    # Check whether this filter is fixed (cannot be changed).
    # @return `logical(1)`
    is_fixed = function() {
      isolate(isTRUE(private$teal_slice$fixed))
    },

    # Check whether this filter is anchored (cannot be removed).
    # @return `logical(1)`
    is_anchored = function() {
      isolate(isTRUE(private$teal_slice$anchored))
    },

    # Check whether this filter is capable of selecting multiple values.
    # @return `logical(1)`
    is_multiple = function() {
      isolate(isTRUE(private$teal_slice$multiple))
    },

    # other ----

    # @description
    # Returns variable label.
    # @return `character(1)`
    get_varlabel = function() {
      private$varlabel
    },

    # @description
    # Return variable name prefixed by `dataname` to be evaluated as extracted object, for example `data$var`
    # @return Call that extracts the variable from the dataset.
    get_varname_prefixed = function(dataname) {
      varname <- private$get_varname()
      varname_backticked <- sprintf("`%s`", varname)
      ans <-
        if (isTRUE(private$extract_type == "list")) {
          sprintf("%s$%s", dataname, varname_backticked)
        } else if (isTRUE(private$extract_type == "matrix")) {
          sprintf("%s[, \"%s\"]", dataname, varname)
        } else {
          varname_backticked
        }
      str2lang(ans)
    },

    # @description
    # Adds `is.na(varname)` moiety to the existing condition call, according to `keep_na` status.
    # @param filter_call `call` raw filter call, as defined by selection
    # @param varname `character(1)` name of a variable
    # @return `call`
    add_keep_na_call = function(filter_call, varname) {
      # No need to deal with NAs.
      if (private$na_count == 0L) {
        return(filter_call)
      }

      if (is.null(filter_call) && isFALSE(private$get_keep_na())) {
        call("!", call("is.na", varname))
      } else if (!is.null(filter_call) && isTRUE(private$get_keep_na())) {
        call("|", call("is.na", varname), filter_call)
      } else if (!is.null(filter_call) && isFALSE(private$get_keep_na())) {
        call("&", call("!", call("is.na", varname)), filter_call)
      }
    },

    # Converts values to the type fitting this `FilterState` and validates the conversion.
    # Raises error if casting does not execute successfully.
    #
    # @param values vector of values
    #
    # @return vector converted to appropriate class
    cast_and_validate = function(values) {
      values
    },

    # Checks length of selection.
    check_length = function(values) {
      values
    },

    # Filters out erroneous values from vector.
    #
    # @param values vector of values
    #
    # @return vector in which values that cannot be set in this FilterState have been dropped
    remove_out_of_bounds_values = function(values) {
      values
    },

    # Checks if the selection is valid in terms of class and length.
    # It should not return anything but raise an error if selection
    # has a wrong class or is outside of possible choices
    validate_selection = function(value) {
      invisible(NULL)
    },

    # @description
    # Checks whether the current settings actually cause any values to be omitted.
    # @return logical scalar
    is_any_filtered = function() {
      if (private$is_choice_limited) {
        TRUE
      } else if (!setequal(private$get_selected(), private$get_choices())) {
        TRUE
      } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
        TRUE
      } else {
        FALSE
      }
    },

    # shiny modules -----

    # @description
    # Server module to display filter summary
    # @param id (`character(1)`) `shiny` module instance id.
    ui_summary = function(id) {
      ns <- NS(id)
      uiOutput(ns("summary"), class = "filter-card-summary")
    },

    # @description
    # UI module to display filter summary
    # @param id (`character(1)`) `shiny` module instance id.
    # @return Nothing. Renders the UI.
    server_summary = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          output$summary <- renderUI(private$content_summary())
        }
      )
    },

    # module with inputs
    ui_inputs = function(id) {
      stop("abstract class")
    },
    # module with inputs
    server_inputs = function(id) {
      stop("abstract class")
    },

    # @description
    # Module displaying inputs in a fixed filter state.
    # There are no input widgets, only selection visualizations.
    # @param id (`character(1)`) `shiny` module instance id.
    ui_inputs_fixed = function(id) {
      ns <- NS(id)
      tags$div(
        class = "choices_state",
        uiOutput(ns("selection"))
      )
    },

    # @description
    # Module creating the display of a fixed filter state.
    # @param id (`character(1)`) `shiny` module instance id.
    server_inputs_fixed = function(id) {
      stop("abstract class")
    },

    # @description
    # Module UI function displaying input to keep or remove NA in the `FilterState` call.
    # Renders a checkbox input only when variable with which `FilterState` has been created contains NAs.
    # @param id (`character(1)`) `shiny` module instance id.
    keep_na_ui = function(id) {
      ns <- NS(id)
      if (private$na_count > 0) {
        isolate({
          countmax <- private$na_count
          countnow <- private$filtered_na_count()
          ui_input <- checkboxInput(
            inputId = ns("value"),
            label = tags$span(
              id = ns("count_label"),
              make_count_text(
                label = "Keep NA",
                countmax = countmax,
                countnow = countnow
              )
            ),
            value = private$get_keep_na()
          )
          tags$div(
            uiOutput(ns("trigger_visible"), inline = TRUE),
            ui_input
          )
        })
      } else {
        NULL
      }
    },

    # @description
    # Module server function to handle NA values in the `FilterState`.
    # Sets `private$slice$keep_na` according to the selection
    # and updates the relevant UI element if `private$slice$keep_na` has been changed by the api.
    # @param id (`character(1)`) `shiny` module instance id.
    # @return `NULL`, invisibly.
    keep_na_srv = function(id) {
      moduleServer(id, function(input, output, session) {
        # 1. renderUI is used here as an observer which triggers only if output is visible
        #  and if the reactive changes - reactive triggers only if the output is visible.
        # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)
        output$trigger_visible <- renderUI({
          updateCountText(
            inputId = "count_label",
            label = "Keep NA",
            countmax = private$na_count,
            countnow = private$filtered_na_count()
          )
          NULL
        })

        # this observer is needed in the situation when private$keep_inf has been
        # changed directly by the api - then it's needed to rerender UI element
        # to show relevant values
        private$session_bindings[[session$ns("keep_na_api")]] <- observeEvent(
          ignoreNULL = FALSE, # nothing selected is possible for NA
          ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
          eventExpr = private$get_keep_na(),
          handlerExpr = {
            if (!setequal(private$get_keep_na(), input$value)) {
              logger::log_debug("{ class(self)[1] }$keep_na_srv@1 changed reactive value, id: { private$get_id() }")
              updateCheckboxInput(
                inputId = "value",
                label = sprintf("Keep NA (%s/%s)", private$filtered_na_count(), private$na_count),
                value = private$get_keep_na()
              )
            }
          }
        )
        private$session_bindings[[session$ns("keep_na")]] <- observeEvent(
          ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput`
          ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
          eventExpr = input$value,
          handlerExpr = {
            logger::log_debug("{ class(self)[1] }$keep_na_srv@2 changed input, id: { private$get_id() }")
            keep_na <- if (is.null(input$value)) {
              FALSE
            } else {
              input$value
            }
            private$set_keep_na(keep_na)
          }
        )
        invisible(NULL)
      })
    }
  )
)

# DatetimeFilterState ------

#' @rdname DatetimeFilterState
#' @docType class
#'
#' @title `FilterState` object for date time data
#'
#' @description  Manages choosing a range of date-times.
#'
#' @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")
#' DatetimeFilterState <- getFromNamespace("DatetimeFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- DatetimeFilterState$new(
#'   x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA),
#'   slice = teal_slice(varname = "x", dataname = "data"),
#'   extract_type = character(0)
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#'   teal_slice(
#'     dataname = "data",
#'     varname = "x",
#'     selected = c(Sys.time() + 3L, Sys.time() + 8L),
#'     keep_na = TRUE
#'   )
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00"))
#' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA)
#' fs <- DatetimeFilterState$new(
#'   x = data_datetime,
#'   slice = teal_slice(
#'     varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE
#'   )
#' )
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   column(4, tags$div(
#'     tags$h4("DatetimeFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, tags$div(
#'     id = "outputs", # div id is needed for toggling the element
#'     tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_datetime"), tags$br(),
#'     tags$h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_datetime"), tags$br(),
#'     tags$h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_datetime"), tags$br()
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Programmatic filter control"),
#'     actionButton("button1_datetime", "set drop NA", width = "100%"), tags$br(),
#'     actionButton("button2_datetime", "set keep NA", width = "100%"), tags$br(),
#'     actionButton("button3_datetime", "set a range", width = "100%"), tags$br(),
#'     actionButton("button4_datetime", "set full range", width = "100%"), tags$br(),
#'     actionButton("button0_datetime", "set initial state", width = "100%"), tags$br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_datetime <- renderPrint(fs$get_call())
#'   output$formatted_datetime <- renderText(fs$format())
#'   output$unformatted_datetime <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_datetime,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_datetime,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_datetime,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)])
#'     )
#'   )
#'   observeEvent(
#'     input$button4_datetime,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = datetimes)
#'     )
#'   )
#'   observeEvent(
#'     input$button0_datetime,
#'     fs$set_state(
#'       teal_slice(
#'         dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE
#'       )
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
DatetimeFilterState <- R6::R6Class( # nolint
  "DatetimeFilterState",
  inherit = FilterState,

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `FilterState` object. This class
    #' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by
    #' default. However, in case when using this module in `teal` app, one needs
    #' timezone of the app user. App user timezone is taken from `session$userData$timezone`
    #' and is set only if object is initialized in `shiny`.
    #'
    #' @param x (`POSIXct` or `POSIXlt`)
    #'   variable to be filtered.
    #' @param x_reactive (`reactive`)
    #'   returning vector of the same type as `x`. Is used to update
    #'   counts following the change in values of the filtered dataset.
    #'   If it is set to `reactive(NULL)` then counts based on filtered
    #'   dataset are not shown.
    #' @param slice (`teal_slice`)
    #'   specification of this filter state.
    #'   `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
    #'   `get_state` returns `teal_slice` object which can be reused in other places.
    #'   Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
    #'   changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
    #' @param extract_type (`character`)
    #'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
    #' - `character(0)` (default) `varname` in the condition call will not be prefixed
    #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
    #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
    #'
    #' @return Object of class `DatetimeFilterState`, invisibly.
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          extract_type = character(0),
                          slice) {
      isolate({
        checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
        checkmate::assert_class(x_reactive, "reactive")

        super$initialize(
          x = x,
          x_reactive = x_reactive,
          slice = slice,
          extract_type = extract_type
        )
        checkmate::assert_multi_class(slice$choices, c("POSIXct", "POSIXlt"), null.ok = TRUE)
        private$set_choices(slice$choices)
        if (is.null(slice$selected)) slice$selected <- slice$choices
        private$set_selected(slice$selected)
      })

      invisible(self)
    },

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For this class returned call looks like
    #' `<varname> >= as.POSIXct(<min>) & <varname> <= <max>)` with optional `is.na(<varname>)`.
    #' @param dataname name of data set; defaults to `private$get_dataname()`
    #' @return `call`
    #'
    get_call = function(dataname) {
      if (isFALSE(private$is_any_filtered())) {
        return(NULL)
      }
      if (missing(dataname)) dataname <- private$get_dataname()
      varname <- private$get_varname_prefixed(dataname)
      choices <- private$get_selected()
      tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone"))
      class <- class(choices)[1L]
      date_fun <- as.name(
        switch(class,
          "POSIXct" = "as.POSIXct",
          "POSIXlt" = "as.POSIXlt"
        )
      )
      choices <- as.character(choices + c(0, 1))
      filter_call <-
        call(
          "&",
          call(
            ">=",
            varname,
            as.call(list(date_fun, choices[1L], tz = tzone))
          ),
          call(
            "<",
            varname,
            as.call(list(date_fun, choices[2L], tz = tzone))
          )
        )
      private$add_keep_na_call(filter_call, varname)
    }
  ),

  # private members ----

  private = list(
    # private methods ----
    set_choices = function(choices) {
      if (is.null(choices)) {
        choices <- as.POSIXct(trunc(range(private$x, na.rm = TRUE), units = "secs"))
      } else {
        choices <- as.POSIXct(choices, units = "secs")
        choices_adjusted <- c(
          max(choices[1L], min(as.POSIXct(private$x), na.rm = TRUE)),
          min(choices[2L], max(as.POSIXct(private$x), na.rm = TRUE))
        )
        if (any(choices != choices_adjusted)) {
          warning(sprintf(
            "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",
            private$get_varname(), private$get_dataname()
          ))
          choices <- choices_adjusted
        }
        if (choices[1L] >= choices[2L]) {
          warning(sprintf(
            "Invalid choices: lower is higher / equal to upper, or not in range of variable values.
            Setting defaults. Varname: %s, dataname: %s.",
            private$get_varname(), private$get_dataname()
          ))
          choices <- range(private$x, na.rm = TRUE)
        }
      }

      private$set_is_choice_limited(private$x, choices)
      private$x <- private$x[
        (
          as.POSIXct(trunc(private$x, units = "secs")) >= choices[1L] &
            as.POSIXct(trunc(private$x, units = "secs")) <= choices[2L]
        ) | is.na(private$x)
      ]
      private$teal_slice$choices <- choices
      invisible(NULL)
    },

    # @description
    # Check whether the initial choices filter out some values of x and set the flag in case.
    set_is_choice_limited = function(xl, choices = NULL) {
      private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE))
      invisible(NULL)
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.POSIXct(values, origin = "1970-01-01 00:00:00")
          if (anyNA(values)) stop()
          values
        },
        error = function(e) stop("Vector of set values must contain values coercible to POSIX.")
      )
    },
    check_length = function(values) {
      if (length(values) != 2) stop("Vector of set values must have length two.")
      if (values[1] > values[2]) {
        warning(
          sprintf(
            "Start date '%s' is set after the end date '%s', the values will be replaced by a default datetime range.",
            values[1], values[2]
          )
        )
        values <- isolate(private$get_choices())
      }
      values
    },
    remove_out_of_bounds_values = function(values) {
      choices <- private$get_choices()
      if (values[1] < choices[1L] || values[1] > choices[2L]) {
        warning(
          sprintf(
            "Value: %s is outside of the range for the column '%s' in dataset '%s', setting minimum possible value.",
            values[1], private$get_varname(), toString(private$get_dataname())
          )
        )
        values[1] <- choices[1L]
      }

      if (values[2] > choices[2L] | values[2] < choices[1L]) {
        warning(
          sprintf(
            "Value: '%s' is outside of the range for the column '%s' in dataset '%s', setting maximum possible value.",
            values[2], private$get_varname(), toString(private$get_dataname())
          )
        )
        values[2] <- choices[2L]
      }

      values
    },

    # shiny modules ----

    # @description
    # UI Module for `DatetimeFilterState`.
    # This UI element contains two date-time selections for `min` and `max`
    # of the range and a checkbox whether to keep the `NA` values.
    # @param id (`character(1)`) `shiny` module instance id.
    ui_inputs = function(id) {
      ns <- NS(id)

      isolate({
        ui_input_1 <- shinyWidgets::airDatepickerInput(
          inputId = ns("selection_start"),
          value = private$get_selected()[1],
          startView = private$get_selected()[1],
          timepicker = TRUE,
          minDate = private$get_choices()[1L],
          maxDate = private$get_choices()[2L],
          update_on = "close",
          addon = "none",
          position = "bottom right"
        )
        ui_input_2 <- shinyWidgets::airDatepickerInput(
          inputId = ns("selection_end"),
          value = private$get_selected()[2],
          startView = private$get_selected()[2],
          timepicker = TRUE,
          minDate = private$get_choices()[1L],
          maxDate = private$get_choices()[2L],
          update_on = "close",
          addon = "none",
          position = "bottom right"
        )
        ui_reset_1 <- actionButton(
          class = "date_reset_button",
          inputId = ns("start_date_reset"),
          label = NULL,
          icon = icon("fas fa-undo")
        )
        ui_reset_2 <- actionButton(
          class = "date_reset_button",
          inputId = ns("end_date_reset"),
          label = NULL,
          icon = icon("fas fa-undo")
        )
        ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm"))
        ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm"))

        tags$div(
          tags$div(
            class = "flex",
            ui_reset_1,
            tags$div(
              class = "flex w-80 filter_datelike_input",
              tags$div(class = "w-45 text-center", ui_input_1),
              tags$span(
                class = "input-group-addon w-10",
                tags$span(class = "input-group-text w-100 justify-content-center", "to"),
                title = "Times are displayed in the local timezone and are converted to UTC in the analysis"
              ),
              tags$div(class = "w-45 text-center", ui_input_2)
            ),
            ui_reset_2
          ),
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

    # @description
    # Server module
    # @param id (`character(1)`) `shiny` module instance id.
    # @return `NULL`.
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("DatetimeFilterState$server initializing, id: { private$get_id() }")
          # this observer is needed in the situation when teal_slice$selected has been
          # changed directly by the api - then it's needed to rerender UI element
          # to show relevant values
          private$session_bindings[[session$ns("selection_api")]] <- observeEvent(
            ignoreNULL = TRUE, # dates needs to be selected
            ignoreInit = TRUE, # on init selected == default, so no need to trigger
            eventExpr = private$get_selected(),
            handlerExpr = {
              start_date <- input$selection_start
              end_date <- input$selection_end
              if (!all(private$get_selected() == c(start_date, end_date))) {
                logger::log_debug("DatetimeFilterState$server@1 state changed, id: { private$get_id() }")
                if (private$get_selected()[1] != start_date) {
                  shinyWidgets::updateAirDateInput(
                    session = session,
                    inputId = "selection_start",
                    value = private$get_selected()[1]
                  )
                }

                if (private$get_selected()[2] != end_date) {
                  shinyWidgets::updateAirDateInput(
                    session = session,
                    inputId = "selection_end",
                    value = private$get_selected()[2]
                  )
                }
              }
            }
          )


          private$session_bindings[[session$ns("selection_start")]] <- observeEvent(
            ignoreNULL = TRUE, # dates needs to be selected
            ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
            eventExpr = input$selection_start,
            handlerExpr = {
              logger::log_debug("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
              start_date <- input$selection_start
              end_date <- private$get_selected()[[2]]
              tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))
              attr(start_date, "tzone") <- tzone

              if (start_date > end_date) {
                showNotification(
                  "Start date must not be greater than the end date. Ignoring selection.",
                  type = "warning"
                )
                shinyWidgets::updateAirDateInput(
                  session = session,
                  inputId = "selection_start",
                  value = private$get_selected()[1] # sets back to latest selected value
                )
                return(NULL)
              }

              private$set_selected(c(start_date, end_date))
            }
          )

          private$session_bindings[[session$ns("selection_end")]] <- observeEvent(
            ignoreNULL = TRUE, # dates needs to be selected
            ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
            eventExpr = input$selection_end,
            handlerExpr = {
              start_date <- private$get_selected()[1]
              end_date <- input$selection_end
              tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))
              attr(end_date, "tzone") <- tzone

              if (start_date > end_date) {
                showNotification(
                  "End date must not be lower than the start date. Ignoring selection.",
                  type = "warning"
                )
                shinyWidgets::updateAirDateInput(
                  session = session,
                  inputId = "selection_end",
                  value = private$get_selected()[2] # sets back to latest selected value
                )
                return(NULL)
              }

              private$set_selected(c(start_date, end_date))
              logger::log_debug("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
            }
          )

          private$keep_na_srv("keep_na")

          private$session_bindings[[session$ns("reset1")]] <- observeEvent(
            ignoreInit = TRUE, # reset button shouldn't be trigger on init
            ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL
            input$start_date_reset,
            {
              shinyWidgets::updateAirDateInput(
                session = session,
                inputId = "selection_start",
                value = private$get_choices()[1L]
              )
              logger::log_debug("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
            }
          )
          private$session_bindings[[session$ns("reset2")]] <- observeEvent(
            ignoreInit = TRUE, # reset button shouldn't be trigger on init
            ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL
            input$end_date_reset,
            {
              shinyWidgets::updateAirDateInput(
                session = session,
                inputId = "selection_end",
                value = private$get_choices()[2L]
              )
              logger::log_debug("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
            }
          )

          NULL
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("DatetimeFilterState$server initializing, id: { private$get_id() }")

          output$selection <- renderUI({
            vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3)
            tags$div(
              tags$div(icon("clock"), vals[1]),
              tags$div(span(" - "), icon("clock"), vals[2])
            )
          })

          NULL
        }
      )
    },

    # @description
    # UI module to display filter summary
    #  renders text describing selected date range and
    #  if NA are included also
    content_summary = function(id) {
      selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S")
      min <- selected[1]
      max <- selected[2]
      tagList(
        tags$span(
          class = "filter-card-summary-value",
          HTML(min, "&ndash;", max)
        ),
        tags$span(
          class = "filter-card-summary-controls",
          if (private$na_count > 0) {
            tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
          }
        )
      )
    }
  )
)

#' Initialize `FilterState`
#'
#' Initializes a `FilterState` object corresponding to the class of the filtered variable.
#'
#' @param x (`vector`)
#'   variable to be filtered.
#' @param x_reactive (`reactive`)
#'   returning vector of the same type as `x`. Is used to update
#'   counts following the change in values of the filtered dataset.
#'   If it is set to `reactive(NULL)` then counts based on filtered
#'   dataset are not shown.
#' @param slice (`teal_slice`)
#'   specification of this filter state.
#'   `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
#'   `get_state` returns `teal_slice` object which can be reused in other places.
#'   Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
#'   changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
#' @param extract_type (`character`)
#'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
#' - `character(0)` (default) `varname` in the condition call will not be prefixed
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
#'
#' @examples
#' # use non-exported function from teal.slice
#' init_filter_state <- getFromNamespace("init_filter_state", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- init_filter_state(
#'   x = c(1:10, NA, Inf),
#'   x_reactive = reactive(c(1:10, NA, Inf)),
#'   slice = teal_slice(
#'     varname = "varname",
#'     dataname = "dataname"
#'   ),
#'   extract_type = "matrix"
#' )
#'
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#'
#' ui <- fluidPage(
#'   filter_state$ui(id = "app"),
#'   verbatimTextOutput("call")
#' )
#' server <- function(input, output, session) {
#'   filter_state$server("app")
#'
#'   output$call <- renderText(
#'     deparse1(filter_state$get_call(), collapse = "\n")
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @return `FilterState` object
#' @keywords internal
init_filter_state <- function(x,
                              x_reactive = reactive(NULL),
                              slice,
                              extract_type = character(0)) {
  checkmate::assert_class(x_reactive, "reactive")
  checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)
  checkmate::assert_class(slice, "teal_slice")
  if (length(extract_type) == 1) {
    checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
  }

  if (all(is.na(x))) {
    EmptyFilterState$new(
      x = x,
      x_reactive = x_reactive,
      slice = slice,
      extract_type = extract_type
    )
  } else {
    UseMethod("init_filter_state")
  }
}

#' @keywords internal
#' @export
init_filter_state.default <- function(x,
                                      x_reactive = reactive(NULL),
                                      slice,
                                      extract_type = character(0)) {
  args <- list(
    x = x,
    x_reactive = x_reactive,
    extract_type = extract_type,
    slice
  )

  do.call(FilterState$new, args)
}

#' @keywords internal
#' @export
init_filter_state.logical <- function(x,
                                      x_reactive = reactive(NULL),
                                      slice,
                                      extract_type = character(0)) {
  LogicalFilterState$new(
    x = x,
    x_reactive = x_reactive,
    slice = slice,
    extract_type = extract_type
  )
}

#' @keywords internal
#' @export
init_filter_state.numeric <- function(x,
                                      x_reactive = reactive(NULL),
                                      slice,
                                      extract_type = character(0)) {
  args <- list(
    x = x,
    x_reactive = x_reactive,
    slice = slice,
    extract_type = extract_type
  )

  if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
    do.call(ChoicesFilterState$new, args)
  } else {
    do.call(RangeFilterState$new, args)
  }
}

#' @keywords internal
#' @export
init_filter_state.factor <- function(x,
                                     x_reactive = reactive(NULL),
                                     slice,
                                     extract_type = character(0)) {
  ChoicesFilterState$new(
    x = x,
    x_reactive = x_reactive,
    slice = slice,
    extract_type = extract_type
  )
}

#' @keywords internal
#' @export
init_filter_state.character <- function(x,
                                        x_reactive = reactive(NULL),
                                        slice,
                                        extract_type = character(0)) {
  ChoicesFilterState$new(
    x = x,
    x_reactive = x_reactive,
    slice = slice,
    extract_type = extract_type
  )
}

#' @keywords internal
#' @export
init_filter_state.Date <- function(x,
                                   x_reactive = reactive(NULL),
                                   slice,
                                   extract_type = character(0)) {
  args <- list(
    x = x,
    x_reactive = x_reactive,
    slice = slice,
    extract_type = extract_type
  )

  if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
    do.call(ChoicesFilterState$new, args)
  } else {
    do.call(DateFilterState$new, args)
  }
}

#' @keywords internal
#' @export
init_filter_state.POSIXct <- function(x,
                                      x_reactive = reactive(NULL),
                                      slice,
                                      extract_type = character(0)) {
  args <- list(
    x = x,
    x_reactive = x_reactive,
    slice = slice,
    extract_type = extract_type
  )

  if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
    do.call(ChoicesFilterState$new, args)
  } else {
    do.call(DatetimeFilterState$new, args)
  }
}

#' @keywords internal
#' @export
init_filter_state.POSIXlt <- function(x,
                                      x_reactive = reactive(NULL),
                                      slice,
                                      extract_type = character(0)) {
  args <- list(
    x = x,
    x_reactive = x_reactive,
    slice = slice,
    extract_type = extract_type
  )

  if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
    do.call(ChoicesFilterState$new, args)
  } else {
    do.call(DatetimeFilterState$new, args)
  }
}


#' Initialize a `FilterStateExpr` object
#'
#' @param slice (`teal_slice_expr`)
#'   specifying this filter state.
#'
#' @return `FilterStateExpr` object
#' @keywords internal
init_filter_state_expr <- function(slice) {
  FilterStateExpr$new(slice)
}


#' Get hex code of the current Bootstrap theme color.
#'
#' Determines the color specification for the currently active Bootstrap color theme and returns one queried color.
#'
#' @param color (`character(1)`) naming one of the available theme colors
#' @param alpha either a `numeric(1)` or `character(1)` specifying transparency
#'              in the range of `0-1` or a hexadecimal value `00-ff`, respectively;
#'              set to NULL to omit adding the alpha channel
#'
#' @return Named `character(1)` containing a hexadecimal color representation.
#'
#' @examples
#' fetch_bs_color <- getFromNamespace("fetch_bs_color", "teal.slice")
#' fetch_bs_color("primary")
#' fetch_bs_color("danger", 0.35)
#' fetch_bs_color("danger", "80")
#'
#' @keywords internal
#'
fetch_bs_color <- function(color, alpha = NULL) {
  checkmate::assert_string(color)
  checkmate::assert(
    checkmate::check_number(alpha, lower = 0, upper = 1, null.ok = TRUE),
    checkmate::check_string(alpha, pattern = "[0-9a-f]{2}", null.ok = TRUE)
  )

  # locate file that describes the current theme
  sass_file <- if (utils::packageVersion("bslib") < as.package_version("0.5.1.9000")) {
    bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]]
  } else {
    bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]][[1]]
  }
  sass_file <- attr(sass_file, "sass_file_path")

  # load scss file that encodes variables
  variables_file <- readLines(sass_file)
  # locate theme color variables
  ind <- grep("// scss-docs-(start|end) theme-color-variables", variables_file)
  color_definitions <- variables_file[(ind[1] + 1L):(ind[2] - 1L)]

  # extract colors names
  color_names <- sub("(\\$)(\\w.+)(:.+)", "\\2", color_definitions)

  # verify that an available color was requested
  checkmate::assert_choice(color, color_names)

  # extract color references
  color_references <- sub("(\\$)(\\w.+)(:\\s.+\\$)(\\w.+)(\\s.+)", "\\4", color_definitions)

  # translate references to color codes
  color_specification <- structure(color_references, names = color_names)
  color_specification <- vapply(color_specification, function(x) {
    line <- grep(sprintf("^\\$%s:\\s+#\\w{6}\\s+!default", x), variables_file, value = TRUE)
    code <- sub("(.+)(#\\w{6})(\\s+.+)", "\\2", line)
    code
  }, character(1L))

  if (!is.null(alpha)) {
    if (is.numeric(alpha)) alpha <- as.hexmode(ceiling(255 * alpha))
  }

  paste0(color_specification[color], alpha)
}

#' Specify single filter
#'
#' Create a `teal_slice` object that holds complete information on filtering one variable.
#' Check out [`teal_slice-utilities`] functions for working with `teal_slice` object.
#'
#' `teal_slice` object fully describes filter state and can be used to create,
#' modify, and delete a filter state. A `teal_slice` contains a number of common fields
#' (all named arguments of `teal_slice`), some of which are mandatory, but only
#' `dataname` and  either `varname` or `expr` must be specified, while the others have default
#' values.
#'
#' Setting any of the other values to `NULL` means that those properties will not be modified
#' (when setting an existing state) or that they will be determined by data (when creating new a new one).
#' Entire object is `FilterState` class member and can be accessed with `FilterState$get_state()`.
#'
#' A `teal_slice` can come in two flavors:
#' 1. `teal_slice_var` -
#' this describes a typical interactive filter that refers to a single variable, managed by the `FilterState` class.
#' This class is created when `varname` is specified.
#' The object retains all fields specified in the call. `id` can be created by default and need not be specified.
#' 2. `teal_slice_expr` -
#' this describes a filter state that refers to an expression, which can potentially include multiple variables,
#' managed by the `FilterStateExpr` class.
#' This class is created when `expr` is specified.
#' `dataname` and `anchored` are retained, `fixed` is set to `TRUE`, `id` becomes mandatory, `title`
#' remains optional, while other arguments are disregarded.
#'
#' A teal_slice can be passed `FilterState`/`FilterStateExpr` constructors to instantiate an object.
#' It can also be passed to `FilterState$set_state` to modify the state.
#' However, once a `FilterState` is created, only the mutable features can be set with a teal_slice:
#' `selected`, `keep_na` and `keep_inf`.
#'
#' Special consideration is given to two fields: `fixed` and `anchored`.
#' These are always immutable logical flags that default to `FALSE`.
#' In a `FilterState` instantiated with `fixed = TRUE` the features
#' `selected`, `keep_na`, `keep_inf` cannot be changed.
#' Note that a `FilterStateExpr` is always considered to have `fixed = TRUE`.
#' A `FilterState` instantiated with `anchored = TRUE` cannot be removed.
#'
#' @section Filters in `SumarizedExperiment` and `MultiAssayExperiment` objects:
#'
#' To establish a filter on a column in a `data.frame`, `dataname` and `varname` are sufficient.
#' `MultiAssayExperiment` objects can be filtered either on their `colData` slot (which contains subject information)
#' or on their experiments, which are stored in the `experimentList` slot.
#' For filters referring to `colData` no extra arguments are needed.
#' If a filter state is created for an experiment, that experiment name must be specified in the `experiment` argument.
#' Furthermore, to specify filter for an `SummarizedExperiment` one must also set `arg`
#' (`"subset"`  or `"select"`, arguments in the [subset()] function for `SummarizedExperiment`)
#' in order to determine whether the filter refers to the `SE`'s `rowData` or `colData`.
#'
#' @param dataname (`character(1)`) name of data set
#' @param varname (`character(1)`) name of variable
#' @param id (`character(1)`) identifier of the filter. Must be specified when `expr` is set.
#'  When `varname` is specified then `id` is set to `"{dataname} {varname}"` by default.
#' @param expr (`character(1)`) string providing a logical expression.
#'  Must be a valid `R` expression which can be evaluated in the context of the data set.
#'  For a `data.frame` `var == "x"` is sufficient, but `MultiAssayExperiment::subsetByColData`
#'  requires `dataname` prefix, *e.g.* `data$var == "x"`.
#' @param choices (`vector`) optional, specifies allowed choices;
#' When specified it should be a subset of values in variable denoted by `varname`;
#' Type and size depends on variable type. Factors are coerced to character.
#' @param selected (`vector`) optional, specifies selected values from `choices`;
#' Type and size depends on variable type. Factors are coerced to character.
#' @param multiple (`logical(1)`) optional flag specifying whether more than one value can be selected;
#' only applicable to `ChoicesFilterState` and `LogicalFilterState`
#' @param keep_na (`logical(1)`) optional flag specifying whether to keep missing values
#' @param keep_inf (`logical(1)`) optional flag specifying whether to keep infinite values
#' @param fixed (`logical(1)`) flag specifying whether to fix this filter state (forbid setting state)
#' @param anchored (`logical(1)`) flag specifying whether to lock this filter state (forbid removing and inactivating)
#' @param title (`character(1)`) optional title of the filter. Ignored when `varname` is set.
#' @param ... additional arguments which can be handled by extensions of `teal.slice` classes.
#'
#' @return A `teal.slice` object. Depending on whether `varname` or `expr` was specified, the resulting
#' `teal_slice` also receives class `teal_slice_var` or `teal_slice_expr`, respectively.
#'
#' @note Date time objects of `POSIX*t` classes are printed as strings after converting to UTC timezone.
#'
#' @examples
#' x1 <- teal_slice(
#'   dataname = "data",
#'   id = "Female adults",
#'   expr = "SEX == 'F' & AGE >= 18",
#'   title = "Female adults"
#' )
#' x2 <- teal_slice(
#'   dataname = "data",
#'   varname = "var",
#'   choices = c("F", "M", "U"),
#'   selected = "F",
#'   keep_na = TRUE,
#'   keep_inf = TRUE,
#'   fixed = FALSE,
#'   anchored = FALSE,
#'   multiple = TRUE,
#'   id = "Gender",
#'   extra_arg = "extra"
#' )
#'
#' is.teal_slice(x1)
#' as.list(x1)
#' as.teal_slice(list(dataname = "a", varname = "var"))
#' format(x1)
#' format(x1, show_all = TRUE, trim_lines = FALSE)
#' print(x1)
#' print(x1, show_all = TRUE, trim_lines = FALSE)
#'
#' @seealso [`teal_slices`],
#' [`is.teal_slice`], [`as.teal_slice`], [`as.list.teal_slice`], [`print.teal_slice`], [`format.teal_slice`]
#'
#' @export
teal_slice <- function(dataname,
                       varname,
                       id,
                       expr,
                       choices = NULL,
                       selected = NULL,
                       keep_na = NULL,
                       keep_inf = NULL,
                       fixed = FALSE,
                       anchored = FALSE,
                       multiple = TRUE,
                       title = NULL,
                       ...) {
  checkmate::assert_string(dataname)
  checkmate::assert_flag(fixed)
  checkmate::assert_flag(anchored)

  formal_args <- as.list(environment())

  if (!missing(expr) && !missing(varname)) {
    stop("Must provide either `expr` or `varname`.")
  } else if (!missing(expr)) {
    checkmate::assert_string(id)
    checkmate::assert_string(title)
    checkmate::assert_string(expr)

    formal_args$fixed <- TRUE
    ts_expr_args <- c("dataname", "id", "expr", "fixed", "anchored", "title")
    formal_args <- formal_args[ts_expr_args]
    ans <- do.call(reactiveValues, c(formal_args, list(...)))
    class(ans) <- c("teal_slice_expr", "teal_slice", class(ans))
  } else if (!missing(varname)) {
    checkmate::assert_string(varname)
    checkmate::assert_multi_class(choices, .filterable_class, null.ok = TRUE)
    checkmate::assert_multi_class(selected, .filterable_class, null.ok = TRUE)
    checkmate::assert_flag(keep_na, null.ok = TRUE)
    checkmate::assert_flag(keep_inf, null.ok = TRUE)
    checkmate::assert_flag(multiple)

    ts_var_args <- c(
      "dataname", "varname", "id", "choices", "selected", "keep_na", "keep_inf",
      "fixed", "anchored", "multiple"
    )
    formal_args <- formal_args[ts_var_args]
    args <- c(formal_args, list(...))
    args[c("choices", "selected")] <-
      lapply(args[c("choices", "selected")], function(x) if (is.factor(x)) as.character(x) else x)
    if (missing(id)) {
      args$id <- get_default_slice_id(args)
    } else {
      checkmate::assert_string(id)
    }
    ans <- do.call(reactiveValues, args)
    class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
  } else {
    stop("Must provide either `expr` or `varname`.")
  }

  ans
}

#' `teal_slice` utility functions
#'
#' Helper functions for working with [`teal_slice`] object.
#' @param x (`teal.slice`)
#' @param show_all (`logical(1)`) indicating whether to show all fields. If set to `FALSE`,
#'  only non-NULL elements will be printed.
#' @param trim_lines (`logical(1)`) indicating whether to trim lines when printing.
#' @param ... additional arguments passed to other functions.
#' @name teal_slice-utilities
#' @inherit teal_slice examples
#' @keywords internal

#' @rdname teal_slice-utilities
#' @export
#'
is.teal_slice <- function(x) { # nolint
  inherits(x, "teal_slice")
}

#' @rdname teal_slice-utilities
#' @export
#'
as.teal_slice <- function(x) { # nolint
  checkmate::assert_list(x, names = "named")
  do.call(teal_slice, x)
}

#' @rdname teal_slice-utilities
#' @export
#'
as.list.teal_slice <- function(x, ...) {
  formal_args <- setdiff(names(formals(teal_slice)), "...")

  x <- if (isRunning()) {
    reactiveValuesToList(x)
  } else {
    isolate(reactiveValuesToList(x))
  }

  formal_args <- intersect(formal_args, names(x))
  extra_args <- rev(setdiff(names(x), formal_args))

  x[c(formal_args, extra_args)]
}


#' @rdname teal_slice-utilities
#' @export
#'
format.teal_slice <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
  checkmate::assert_flag(show_all)
  checkmate::assert_flag(trim_lines)

  x_list <- as.list(x)
  if (!show_all) x_list <- Filter(Negate(is.null), x_list)

  jsonify(x_list, trim_lines)
}

#' @rdname teal_slice-utilities
#' @export
#'
print.teal_slice <- function(x, ...) {
  cat(format(x, ...))
  invisible(x)
}


# format utils -----

#' Convert a list to a justified `JSON` string
#'
#' This function takes a list and converts it to a `JSON` string.
#' The resulting `JSON` string is then optionally justified to improve readability
#' and trimmed to easier fit in the console when printing.
#'
#' @param x (`list`), possibly recursive, obtained from `teal_slice` or `teal_slices`.
#' @param trim_lines (`logical(1)`) flag specifying whether to trim lines of the `JSON` string.
#' @return A `JSON` string representation of the input list.
#' @keywords internal
#'
jsonify <- function(x, trim_lines) {
  checkmate::assert_list(x)

  x_json <- to_json(x)
  x_json_justified <- justify_json(x_json)
  if (trim_lines) x_json_justified <- trim_lines_json(x_json_justified)
  paste(x_json_justified, collapse = "\n")
}

#' Converts a list to a `JSON` string
#'
#' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string.
#' Ensures proper unboxing of list elements.
#' This function is used by the `format` methods for `teal_slice` and `teal_slices`.
#' @param x (`list`) possibly recursive, obtained from `teal_slice` or `teal_slices`.
#' @return A `JSON` string.
#
#' @param x (`list`) representation of `teal_slices` object.
#' @keywords internal
#'
to_json <- function(x) {
  no_unbox <- function(x) {
    vars <- c("selected", "choices")
    if (is.list(x)) {
      for (var in vars) {
        if (!is.null(x[[var]])) x[[var]] <- I(format_time(x[[var]]))
      }
      lapply(x, no_unbox)
    } else {
      x
    }
  }

  jsonlite::toJSON(no_unbox(x), pretty = TRUE, auto_unbox = TRUE, digits = 16, null = "null")
}

#' Format `POSIXt` for storage
#'
#' Convert `POSIXt` date time object to character representation in UTC time zone.
#'
#' Date times are stored as string representations expressed in the UTC time zone.
#' The storage format is `YYYY-MM-DD HH:MM:SS`.
#'
#' @param x (`POSIXt`) vector of date time values or anything else
#'
#' @return If `x` is of class `POSIXt`, a character vector, otherwise `x` itself.
#'
#' @keywords internal
format_time <- function(x) {
  if ("POSIXt" %in% class(x)) {
    format(x, format = "%Y-%m-%d %H:%M:%S", usetz = TRUE, tz = "UTC")
  } else {
    x
  }
}

#' Justify colons in `JSON` string
#'
#' This function takes a `JSON` string as input, splits it into lines, and pads element names
#' with spaces so that colons are justified between lines.
#'
#' @param json (`character(1)`) a `JSON` string.
#'
#' @return A list of character strings, which can be collapsed into a `JSON` string.
#'
#' @keywords internal
justify_json <- function(json) {
  format_name <- function(name, name_width) {
    if (nchar(name) == 1 || nchar(gsub("\\s", "", name)) <= 2) {
      return(name)
    } else if (grepl("slices|attributes", name)) {
      paste0(name, ":")
    } else {
      paste(format(name, width = name_width), ":")
    }
  }
  json_lines <- strsplit(json, "\n")[[1]]
  json_lines_split <- regmatches(json_lines, regexpr(":", json_lines), invert = TRUE)
  name_width <- max(unlist(regexpr(":", json_lines))) - 1
  vapply(json_lines_split, function(x) paste0(format_name(x[1], name_width), stats::na.omit(x[2])), character(1))
}

#' Trim lines in `JSON` string
#'
#' This function takes a `JSON` string as input and returns a modified version of the
#' input where the values portion of each line is trimmed for a less messy console output.
#'
#' @param x (`character`)
#'
#' @return A character string trimmed after a certain hard-coded number of characters in the value portion.
#'
#' @keywords internal
#'
trim_lines_json <- function(x) {
  name_width <- max(unlist(gregexpr(":", x))) - 1
  trim_position <- name_width + 37L
  x_trim <- substr(x, 1, trim_position)
  substr(x_trim, trim_position - 2, trim_position) <- "..."
  x_trim
}

#' Default `teal_slice` id
#'
#' Create a slice id if none provided.
#'
#' Function returns a default `id` for a `teal_slice` object which needs
#' to be distinct from other `teal_slice` objects created for any
#' `FilterStates` object. Returned `id` can be treated as a location of
#' a vector on which `FilterState` is built:
#' - for a `data.frame` `id` concatenates `dataname` and `varname`.
#' - for a `MultiAssayExperiment` `id` concatenates `dataname`, `varname`,
#' `experiment` and `arg`, so that one can add `teal_slice` for a `varname`
#' which exists in multiple `SummarizedExperiment`s or exists in both `colData`
#' and `rowData` of given experiment.
#' For such a vector `teal.slice` doesn't allow to activate more than one filters.
#' In case of `teal_slice_expr` `id` is mandatory and must be unique.
#'
#' @param x (`teal_slice` or `list`)
#' @return (`character(1)`) `id` for a `teal_slice` object.
#'
#' @keywords internal
get_default_slice_id <- function(x) {
  checkmate::assert_multi_class(x, c("teal_slice", "list"))
  isolate({
    if (inherits(x, "teal_slice_expr") || is.null(x$varname)) {
      x$id
    } else {
      paste(
        Filter(
          length,
          as.list(x)[c("dataname", "varname", "experiment", "arg")]
        ),
        collapse = " "
      )
    }
  })
}

# LogicalFilterState ------

#' @name LogicalFilterState
#' @docType class
#'
#' @title `FilterState` object for logical data
#'
#' @description Manages choosing a logical state.
#'
#' @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")
#' LogicalFilterState <- getFromNamespace("LogicalFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- LogicalFilterState$new(
#'   x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE),
#'   slice = teal_slice(varname = "x", dataname = "data")
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#'   teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE)
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA)
#' fs <- LogicalFilterState$new(
#'   x = data_logical,
#'   slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)
#' )
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   column(4, tags$div(
#'     tags$h4("LogicalFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, tags$div(
#'     id = "outputs", # div id is needed for toggling the element
#'     tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_logical"), tags$br(),
#'     tags$h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_logical"), tags$br(),
#'     tags$h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_logical"), tags$br()
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Programmatic filter control"),
#'     actionButton("button1_logical", "set drop NA", width = "100%"), tags$br(),
#'     actionButton("button2_logical", "set keep NA", width = "100%"), tags$br(),
#'     actionButton("button3_logical", "set a selection", width = "100%"), tags$br(),
#'     actionButton("button0_logical", "set initial state", width = "100%"), tags$br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_logical <- renderPrint(fs$get_call())
#'   output$formatted_logical <- renderText(fs$format())
#'   output$unformatted_logical <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_logical,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_logical,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_logical,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE))
#'   )
#'   observeEvent(
#'     input$button0_logical,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
LogicalFilterState <- R6::R6Class( # nolint
  "LogicalFilterState",
  inherit = FilterState,

  # public methods ----
  public = list(

    #' @description
    #' Initialize a `FilterState` object.
    #'
    #' @param x (`logical`)
    #'   variable to be filtered.
    #' @param x_reactive (`reactive`)
    #'   returning vector of the same type as `x`. Is used to update
    #'   counts following the change in values of the filtered dataset.
    #'   If it is set to `reactive(NULL)` then counts based on filtered
    #'   dataset are not shown.
    #' @param slice (`teal_slice`)
    #'   specification of this filter state.
    #'   `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
    #'   `get_state` returns `teal_slice` object which can be reused in other places.
    #'   Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
    #'   changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
    #' @param extract_type (`character`)
    #'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
    #' - `character(0)` (default) `varname` in the condition call will not be prefixed
    #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
    #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
    #'
    #' @return Object of class `LogicalFilterState`, invisibly.
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          extract_type = character(0),
                          slice) {
      isolate({
        checkmate::assert_logical(x)
        checkmate::assert_logical(slice$selected, null.ok = TRUE)
        super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type)

        private$set_choices(slice$choices)
        if (is.null(slice$multiple)) slice$multiple <- FALSE
        if (is.null(slice$selected) && slice$multiple) {
          slice$selected <- private$get_choices()
        } else if (length(slice$selected) != 1 && !slice$multiple) {
          slice$selected <- TRUE
        }
        private$set_selected(slice$selected)
        df <- factor(x, levels = c(TRUE, FALSE))
        tbl <- table(df)
        private$set_choices_counts(tbl)
      })
      invisible(self)
    },

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally `is.na(<varname>)`
    #' @param dataname name of data set; defaults to `private$get_dataname()`
    #' @return `call`
    #'
    get_call = function(dataname) {
      if (isFALSE(private$is_any_filtered())) {
        return(NULL)
      }
      if (missing(dataname)) dataname <- private$get_dataname()
      varname <- private$get_varname_prefixed(dataname)
      choices <- private$get_selected()
      n_choices <- length(choices)

      filter_call <-
        if (n_choices == 1 && choices) {
          varname
        } else if (n_choices == 1 && !choices) {
          call("!", varname)
        } else {
          call("%in%", varname, make_c_call(choices))
        }
      private$add_keep_na_call(filter_call, varname)
    }
  ),

  # private members ----
  private = list(
    choices_counts = integer(0),

    # private methods ----
    set_choices = function(choices) {
      private$teal_slice$choices <- c(TRUE, FALSE)
      invisible(NULL)
    },
    # @description
    # Sets choices_counts private field
    set_choices_counts = function(choices_counts) {
      private$choices_counts <- choices_counts
      invisible(NULL)
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.logical(values)
          if (anyNA(values)) stop()
          values
        },
        error = function(e) stop("Vector of set values must contain values coercible to logical.")
      )
    },
    # If multiple forbidden but selected, restores previous selection with warning.
    check_length = function(values) {
      if (!private$is_multiple() && length(values) > 1) {
        warning(
          sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
          "Maintaining previous selection."
        )
        values <- isolate(private$get_selected())
      }
      values
    },

    # Answers the question of whether the current settings and values selected actually filters out any values.
    # @return logical scalar
    is_any_filtered = function() {
      if (private$is_choice_limited) {
        TRUE
      } else if (all(private$choices_counts > 0)) {
        TRUE
      } else if (
        setequal(private$get_selected(), private$get_choices()) &&
          !anyNA(private$get_selected(), private$get_choices())
      ) {
        TRUE
      } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
        TRUE
      } else {
        FALSE
      }
    },

    # shiny modules ----

    # @description
    # UI Module for `EmptyFilterState`.
    # This UI element contains available choices selection and
    # checkbox whether to keep or not keep the `NA` values.
    # @param id (`character(1)`) `shiny` module instance id.
    ui_inputs = function(id) {
      ns <- NS(id)
      isolate({
        countsmax <- private$choices_counts
        countsnow <- if (!is.null(private$x_reactive())) {
          unname(table(factor(private$x_reactive(), levels = private$get_choices())))
        } else {
          NULL
        }

        labels <- countBars(
          inputId = ns("labels"),
          choices = as.character(private$get_choices()),
          countsnow = countsnow,
          countsmax = countsmax
        )
        ui_input <- if (private$is_multiple()) {
          checkboxGroupInput(
            inputId = ns("selection"),
            label = NULL,
            selected = isolate(as.character(private$get_selected())),
            choiceNames = labels,
            choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
            width = "100%"
          )
        } else {
          radioButtons(
            inputId = ns("selection"),
            label = NULL,
            selected = isolate(as.character(private$get_selected())),
            choiceNames = labels,
            choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
            width = "100%"
          )
        }
        tags$div(
          tags$div(
            class = "choices_state",
            uiOutput(ns("trigger_visible"), inline = TRUE),
            ui_input
          ),
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

    # @description
    # Server module
    # @param id (`character(1)`) `shiny` module instance id.
    # @return `NULL`.
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          # this observer is needed in the situation when teal_slice$selected has been
          # changed directly by the api - then it's needed to rerender UI element
          # to show relevant values
          non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))
          output$trigger_visible <- renderUI({
            logger::log_debug("LogicalFilterState$server@1 updating count labels, id: { private$get_id() }")

            countsnow <- if (!is.null(private$x_reactive())) {
              unname(table(factor(non_missing_values(), levels = private$get_choices())))
            } else {
              NULL
            }

            updateCountBars(
              inputId = "labels",
              choices = as.character(private$get_choices()),
              countsmax = private$choices_counts,
              countsnow = countsnow
            )
            NULL
          })

          private$session_bindings[[session$ns("selected_api")]] <- observeEvent(
            ignoreNULL = !private$is_multiple(),
            ignoreInit = TRUE,
            eventExpr = private$get_selected(),
            handlerExpr = {
              if (!setequal(private$get_selected(), input$selection)) {
                logger::log_debug("LogicalFilterState$server@1 state changed, id: { private$get_id() }")
                if (private$is_multiple()) {
                  updateCheckboxGroupInput(
                    inputId = "selection",
                    selected = private$get_selected()
                  )
                } else {
                  updateRadioButtons(
                    inputId = "selection",
                    selected = private$get_selected()
                  )
                }
              }
            }
          )

          private$session_bindings[[session$ns("selection")]] <- observeEvent(
            ignoreNULL = FALSE,
            ignoreInit = TRUE,
            eventExpr = input$selection,
            handlerExpr = {
              logger::log_debug("LogicalFilterState$server@2 selection changed, id: { private$get_id() }")
              # for private$is_multiple() == TRUE input$selection will always have value
              if (is.null(input$selection) && isFALSE(private$is_multiple())) {
                selection_state <- private$get_selected()
              } else {
                selection_state <- as.logical(input$selection)
              }

              if (is.null(selection_state)) {
                selection_state <- logical(0)
              }
              private$set_selected(selection_state)
            }
          )

          private$keep_na_srv("keep_na")

          NULL
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("LogicalFilterState$server initializing, id: { private$get_id() }")

          output$selection <- renderUI({
            countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices())))
            countsmax <- private$choices_counts

            ind <- private$get_choices() %in% private$get_selected()
            countBars(
              inputId = session$ns("labels"),
              choices = private$get_selected(),
              countsnow = countsnow[ind],
              countsmax = countsmax[ind]
            )
          })

          NULL
        }
      )
    },

    # @description
    # Server module to display filter summary
    #  renders text describing whether TRUE or FALSE is selected
    #  and if NA are included also
    content_summary = function(id) {
      tagList(
        tags$span(
          class = "filter-card-summary-value",
          toString(private$get_selected())
        ),
        tags$span(
          class = "filter-card-summary-controls",
          if (private$na_count > 0) {
            tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
          }
        )
      )
    }
  )
)

# DataframeFilteredDataset ------

#' @name DataframeFilteredDataset
#' @docType class
#' @title The `DataframeFilteredDataset` `R6` class
#'
#' @examples
#' # use non-exported function from teal.slice
#' DataframeFilteredDataset <- getFromNamespace("DataframeFilteredDataset", "teal.slice")
#'
#' library(shiny)
#'
#' ds <- DataframeFilteredDataset$new(iris, "iris")
#' ds$set_filter_state(
#'   teal_slices(
#'     teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),
#'     teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))
#'   )
#' )
#' isolate(ds$get_filter_state())
#' isolate(ds$get_call())
#'
#' ## set_filter_state
#' dataset <- DataframeFilteredDataset$new(iris, "iris")
#' fs <- teal_slices(
#'   teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),
#'   teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))
#' )
#' dataset$set_filter_state(state = fs)
#' isolate(dataset$get_filter_state())
#'
#' @keywords internal
#'
DataframeFilteredDataset <- R6::R6Class( # nolint
  classname = "DataframeFilteredDataset",
  inherit = FilteredDataset,

  # public fields ----
  public = list(

    #' @description
    #' Initializes this `DataframeFilteredDataset` object.
    #'
    #' @param dataset (`data.frame`)
    #'  single `data.frame` for which filters are rendered.
    #' @param dataname (`character(1)`)
    #'  syntactically valid name given to the dataset.
    #' @param keys (`character`) optional
    #'  vector of primary key column names.
    #' @param parent_name (`character(1)`)
    #'   name of the parent dataset.
    #' @param parent (`reactive`)
    #'   that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`.
    #'   Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset`
    #'   based on the changes in `parent`.
    #' @param join_keys (`character`)
    #'   vector of names of columns in this dataset to join with `parent` dataset.
    #'   If column names in the parent do not match these, they should be given as the names of this vector.
    #' @param label (`character(1)`)
    #'   label to describe the dataset.
    #'
    #' @return Object of class `DataframeFilteredDataset`, invisibly.
    #'
    initialize = function(dataset,
                          dataname,
                          keys = character(0),
                          parent_name = character(0),
                          parent = NULL,
                          join_keys = character(0),
                          label = character(0)) {
      checkmate::assert_data_frame(dataset)
      super$initialize(dataset, dataname, keys, label)

      # overwrite filtered_data if there is relationship with parent dataset
      if (!is.null(parent)) {
        checkmate::assert_character(parent_name, len = 1)
        checkmate::assert_character(join_keys, min.len = 1)

        private$parent_name <- parent_name
        private$join_keys <- join_keys

        private$data_filtered_fun <- function(sid = "") {
          checkmate::assert_character(sid)
          if (length(sid)) {
            logger::log_debug("filtering data dataname: { dataname }, sid: { sid }")
          } else {
            logger::log_debug("filtering data dataname: { dataname }")
          }
          env <- new.env(parent = parent.env(globalenv()))
          env[[dataname]] <- private$dataset
          env[[parent_name]] <- parent()
          filter_call <- self$get_call(sid)
          eval_expr_with_msg(filter_call, env)
          get(x = dataname, envir = env)
        }
      }

      private$add_filter_states(
        filter_states = init_filter_states(
          data = dataset,
          data_reactive = private$data_filtered_fun,
          dataname = dataname,
          keys = self$get_keys()
        ),
        id = "filter"
      )

      # todo: Should we make these defaults? It could be handled by the app developer
      if (!is.null(parent)) {
        logger::log_debug("Excluding { parent_name } columns from possible teal_slices for dataname: { dataname }")
        fs <- teal_slices(
          exclude_varnames = structure(
            list(intersect(colnames(dataset), colnames(isolate(parent())))),
            names = private$dataname
          )
        )
        self$set_filter_state(fs)
      }

      invisible(self)
    },

    #' @description
    #' Gets the subset expression.
    #'
    #' This function returns subset expressions equivalent to selected items
    #' within each of `filter_states`. Configuration of the expressions is constant and
    #' depends on `filter_states` type and order which are set during initialization.
    #' This class contains single `FilterStates` which contains single `state_list`
    #' and all `FilterState` objects apply to one argument (`...`) in a `dplyr::filter` call.
    #'
    #' @param sid (`character`)
    #'  when specified, the method returns code containing conditions calls of
    #'  `FilterState` objects with `sid` different to that of this `sid` argument.
    #'
    #' @return Either a `list` of length 1 containing a filter `call`, or `NULL`.
    get_call = function(sid = "") {
      filter_call <- super$get_call(sid)
      dataname <- private$dataname
      parent_dataname <- private$parent_name

      if (!identical(parent_dataname, character(0))) {
        join_keys <- private$join_keys
        parent_keys <- unname(join_keys)
        dataset_keys <- names(join_keys)

        y_arg <- if (length(parent_keys) == 0L) {
          parent_dataname
        } else {
          sprintf(
            "%s[, c(%s), drop = FALSE]",
            parent_dataname,
            toString(dQuote(parent_keys, q = FALSE))
          )
        }

        more_args <- if (length(parent_keys) == 0 || length(dataset_keys) == 0) {
          list()
        } else if (identical(parent_keys, dataset_keys)) {
          list(by = parent_keys)
        } else {
          list(by = stats::setNames(parent_keys, dataset_keys))
        }

        merge_call <- call(
          "<-",
          as.name(dataname),
          as.call(
            c(
              str2lang("dplyr::inner_join"),
              x = as.name(dataname),
              y = str2lang(y_arg),
              more_args
            )
          )
        )

        filter_call <- c(filter_call, merge_call)
      }
      filter_call
    },

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #' @return `NULL`, invisibly.
    #'
    set_filter_state = function(state) {
      isolate({
        logger::log_debug("FilteredDatasetDataframe$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        state_datanames <- unique(vapply(state, `[[`, character(1L), "dataname"))
        checkmate::assert_subset(state_datanames, private$dataname)
        private$get_filter_states()[[1L]]$set_filter_state(state = state)
        invisible(NULL)
      })
    },

    #' @description
    #' Remove one or more `FilterState` form a `FilteredDataset`.
    #'
    #' @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({
        logger::log_debug(
          "FilteredDatasetDataframe$remove_filter_state removing filter(s), dataname: { private$dataname }"
        )

        varnames <- unique(unlist(lapply(state, "[[", "varname")))
        private$get_filter_states()[[1]]$remove_filter_state(state)
      })

      invisible(NULL)
    },

    #' @description
    #' UI module to add filter variable for this dataset.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `shiny.tag`
    ui_add = function(id) {
      ns <- NS(id)
      tagList(
        tags$div(
          tags$label("Add", tags$code(self$get_dataname()), "filter")
        ),
        private$get_filter_states()[["filter"]]$ui_add(id = ns("filter"))
      )
    },

    #' @description
    #' Creates row for filter overview in the form of \cr
    #' `dataname -- observations (remaining/total)` - data.frame
    #' @return A `data.frame`.
    get_filter_overview = function() {
      logger::log_debug("FilteredDataset$srv_filter_overview initializing for dataname: { private$dataname }")
      # Gets filter overview subjects number and returns a list
      # of the number of subjects of filtered/non-filtered datasets
      subject_keys <- if (length(private$parent_name) > 0) {
        names(private$join_keys)
      } else {
        self$get_keys()
      }
      dataset <- self$get_dataset()
      data_filtered <- self$get_dataset(TRUE)
      if (length(subject_keys) == 0) {
        data.frame(
          dataname = private$dataname,
          obs = nrow(dataset),
          obs_filtered = nrow(data_filtered())
        )
      } else {
        data.frame(
          dataname = private$dataname,
          obs = nrow(dataset),
          obs_filtered = nrow(data_filtered()),
          subjects = nrow(unique(dataset[subject_keys])),
          subjects_filtered = nrow(unique(data_filtered()[subject_keys]))
        )
      }
    }
  ),

  # private fields ----
  private = list(
    parent_name = character(0),
    join_keys = character(0)
  )
)

# FilteredData ------

#' @name FilteredData
#' @docType class
#'
#' @title Class to encapsulate filtered datasets
#'
#' @description
#' Manages filtering of all datasets in the application or module.
#'
#' @details
#' The main purpose of this class is to provide a collection of reactive datasets,
#' each dataset having a filter state that determines how it is filtered.
#'
#' For each dataset, `get_filter_expr` returns the call to filter the dataset according
#' to the filter state. The data itself can be obtained through `get_data`.
#'
#' The datasets are filtered lazily, i.e. only when requested / needed in a `shiny` app.
#'
#' By design, any `dataname` set through `set_dataset` cannot be removed because
#' other code may already depend on it. As a workaround, the underlying
#' data can be set to `NULL`.
#'
#' The class currently supports variables of the following types within datasets:
#' - `choices`: variable of type `factor`, e.g. `ADSL$COUNTRY`, `iris$Species`
#'      zero or more options can be selected, when the variable is a factor
#' - `logical`: variable of type `logical`, e.g. `ADSL$TRT_FLAG`
#'      exactly one option must be selected, `TRUE` or `FALSE`
#' - `ranges`: variable of type `numeric`, e.g. `ADSL$AGE`, `iris$Sepal.Length`
#'      numerical range, a range within this range can be selected
#' - `dates`: variable of type `Date`, `POSIXlt`
#' Other variables cannot be used for filtering the data in this class.
#'
#' Common arguments are:
#' 1. `filtered`: whether to return a filtered result or not
#' 2. `dataname`: the name of one of the datasets in this `FilteredData` object
#' 3. `varname`: one of the columns in a dataset
#'
#' @examples
#' # use non-exported function from teal.slice
#' FilteredData <- getFromNamespace("FilteredData", "teal.slice")
#'
#' library(shiny)
#'
#' datasets <- FilteredData$new(list(iris = iris, mtcars = mtcars))
#'
#' # get datanames
#' datasets$datanames()
#'
#' datasets$set_filter_state(
#'   teal_slices(teal_slice(dataname = "iris", varname = "Species", selected = "virginica"))
#' )
#'
#' datasets$set_filter_state(
#'   teal_slices(teal_slice(dataname = "mtcars", varname = "mpg", selected = c(15, 20)))
#' )
#'
#' isolate(datasets$get_filter_state())
#' isolate(datasets$get_call("iris"))
#' isolate(datasets$get_call("mtcars"))
#'
#' @examplesIf requireNamespace("MultiAssayExperiment")
#' ### set_filter_state
#' library(shiny)
#'
#' data(miniACC, package = "MultiAssayExperiment")
#' datasets <- FilteredData$new(list(iris = iris, mae = miniACC))
#' fs <- teal_slices(
#'   teal_slice(
#'     dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4),
#'     keep_na = TRUE, keep_inf = FALSE
#'   ),
#'   teal_slice(
#'     dataname = "iris", varname = "Species", selected = c("setosa", "versicolor"),
#'     keep_na = FALSE
#'   ),
#'   teal_slice(
#'     dataname = "mae", varname = "years_to_birth", selected = c(30, 50),
#'     keep_na = TRUE, keep_inf = FALSE
#'   ),
#'   teal_slice(dataname = "mae", varname = "vital_status", selected = "1", keep_na = FALSE),
#'   teal_slice(dataname = "mae", varname = "gender", selected = "female", keep_na = TRUE),
#'   teal_slice(
#'     dataname = "mae", varname = "ARRAY_TYPE",
#'     selected = "", keep_na = TRUE, experiment = "RPPAArray", arg = "subset"
#'   )
#' )
#' datasets$set_filter_state(state = fs)
#' isolate(datasets$get_filter_state())
#'
#' @keywords internal
#'
FilteredData <- R6::R6Class( # nolint
  "FilteredData",
  # public methods ----
  public = list(
    #' @description
    #' Initialize a `FilteredData` object.
    #' @param data_objects (`named list`)
    #'   List of data objects.
    #'   Names of the list will be used as `dataname` for respective datasets.
    #' @param join_keys (`join_keys`) optional joining keys, see [`teal.data::join_keys()`].
    #'
    initialize = function(data_objects, join_keys = teal.data::join_keys()) {
      checkmate::assert_list(data_objects, any.missing = FALSE, min.len = 0, names = "unique")
      # unpack data.object from the nested list
      data_objects <- lapply(data_objects, function(dataset) {
        if (is.list(dataset) && "dataset" %in% names(dataset)) {
          dataset$dataset
        } else {
          dataset
        }
      })

      # Note the internals of data_objects are checked in set_dataset
      checkmate::assert_class(join_keys, "join_keys")
      self$set_join_keys(join_keys)
      child_parent <- sapply(
        names(data_objects),
        function(i) teal.data::parent(join_keys, i),
        USE.NAMES = TRUE,
        simplify = FALSE
      )
      ordered_datanames <- topological_sort(child_parent)
      ordered_datanames <- intersect(ordered_datanames, names(data_objects))

      for (dataname in ordered_datanames) {
        ds_object <- data_objects[[dataname]]
        self$set_dataset(data = ds_object, dataname = dataname)
      }

      self$set_available_teal_slices(x = reactive(NULL))

      invisible(self)
    },

    #' @description
    #' Gets `datanames`.
    #' @details
    #' The `datanames` are returned in the order in which they must be evaluated (in case of dependencies).
    #' @return Character vector.
    datanames = function() {
      names(private$filtered_datasets)
    },

    #' @description
    #' Gets data label for the dataset.
    #' Useful to display in `Show R Code`.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @return Character string.
    get_datalabel = function(dataname) {
      private$get_filtered_dataset(dataname)$get_dataset_label()
    },

    #' @description
    #' Set list of external filter states available for activation.
    #' @details
    #' Unlike adding new filter from the column, these filters can come with some prespecified settings.
    #' `teal_slices` are wrapped in a `reactive` so they can be updated from elsewhere in the app.
    #' Filters passed in `x` are limited to those that can be set for this `FilteredData` object,
    #' i.e. they have the correct `dataname` and `varname` (waived `teal_slice_fixed` as they do not have `varname`).
    #' List is accessible in `ui/srv_active` through `ui/srv_available_filters`.
    #' @param x (`reactive`)
    #'  should return `teal_slices`
    #' @return `NULL`, invisibly.
    set_available_teal_slices = function(x) {
      checkmate::assert_class(x, "reactive")
      private$available_teal_slices <- reactive({
        # Available filters should be limited to the ones relevant for this FilteredData.
        current_state <- isolate(self$get_filter_state())
        allowed <- attr(current_state, "include_varnames")
        forbidden <- attr(current_state, "exclude_varnames")
        foo <- function(slice) {
          if (slice$dataname %in% self$datanames()) {
            if (slice$fixed) {
              TRUE
            } else {
              isTRUE(slice$varname %in% allowed[[slice$dataname]]) ||
                isFALSE(slice$varname %in% forbidden[[slice$dataname]])
            }
          } else {
            FALSE
          }
        }
        Filter(foo, x())
      })
      invisible(NULL)
    },

    #' @description
    #' Get list of filter states available for this object.
    #' @details
    #' All `teal_slice` objects that have been created since the beginning of the app session
    #' are stored in one `teal_slices` object. This returns a subset of that `teal_slices`,
    #' describing filter states that can be set for this object.
    #' @return `reactive` that returns `teal_slices`.
    get_available_teal_slices = function() {
      private$available_teal_slices
    },

    # datasets methods ----

    #' @description
    #' Gets a `call` to filter the dataset according to the filter state.
    #' @details
    #' It returns a `call` to filter the dataset only, assuming the
    #' other (filtered) datasets it depends on are available.
    #'
    #' Together with `self$datanames()` which returns the datasets in the correct
    #' evaluation order, this generates the whole filter code, see the function
    #' `FilteredData$get_filter_code`.
    #'
    #' For the return type, note that `rlang::is_expression` returns `TRUE` on the
    #' return type, both for base `R` expressions and calls (single expression,
    #' capturing a function call).
    #'
    #' The filtered dataset has the name given by `self$filtered_dataname(dataname)`
    #'
    #' This can be used for the `Show R Code` generation.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #'
    #' @return A list of `call`s.
    #'
    get_call = function(dataname) {
      checkmate::assert_subset(dataname, self$datanames())
      private$get_filtered_dataset(dataname)$get_call()
    },

    #' @description
    #' Gets filtered or unfiltered dataset.
    #'
    #' For `filtered = FALSE`, the original data set with `set_data` is returned including all attributes.
    #'
    #' @param dataname (`character(1)`) name of the dataset.
    #' @param filtered (`logical(1)`) whether to return a filtered or unfiltered dataset.
    #'
    #' @return A data object, a `data.frame` or a `MultiAssayExperiment`.
    #'
    get_data = function(dataname, filtered = TRUE) {
      checkmate::assert_subset(dataname, self$datanames())
      checkmate::assert_flag(filtered)
      data <- private$get_filtered_dataset(dataname)$get_dataset(filtered)
      if (filtered) data() else data
    },

    #' @description
    #' Get join keys between two datasets.
    #'
    #' @return `join_keys`
    #'
    get_join_keys = function() {
      private$join_keys
    },

    #' @description
    #' Creates filter overview table to be displayed in the application.
    #' One row is created per dataset, according to the `get_filter_overview` methods
    #' of the contained `FilteredDataset` objects.
    #'
    #' @param datanames (`character`) vector of dataset names.
    #'
    #' @return A `data.frame` listing the numbers of observations in all datasets.
    #'
    get_filter_overview = function(datanames) {
      rows <- lapply(
        datanames,
        function(dataname) {
          private$get_filtered_dataset(dataname)$get_filter_overview()
        }
      )
      unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1))
      dplyr::bind_rows(c(rows[!unssuported_idx], rows[unssuported_idx]))
    },

    #' @description
    #' Get keys for the dataset.
    #'
    #' @param dataname (`character(1)`) name of the dataset.
    #'
    #' @return Character vector of key column names.
    #'
    get_keys = function(dataname) {
      private$get_filtered_dataset(dataname)$get_keys()
    },

    #' @description
    #' Adds a dataset to this `FilteredData`.
    #'
    #' @details
    #' `set_dataset` creates a `FilteredDataset` object which keeps `dataset` for the filtering purpose.
    #' If this data has a parent specified in the `join_keys` object stored in `private$join_keys`
    #' then created `FilteredDataset` (child) gets linked with other `FilteredDataset` (parent).
    #' "Child" dataset return filtered data then dependent on the reactive filtered data of the
    #' "parent". See more in documentation of `parent` argument in `DataframeFilteredDataset` constructor.
    #'
    #' @param data (`data.frame` or `MultiAssayExperiment`)
    #'   data to be filtered.
    #'
    #' @param dataname (`character(1)`)
    #'   the name of the `dataset` to be added to this object.
    #'
    #' @return `self`, invisibly.
    #'
    set_dataset = function(data, dataname) {
      checkmate::assert_string(dataname)
      logger::log_debug("FilteredData$set_dataset setting dataset, name: { dataname }")

      parent_dataname <- teal.data::parent(private$join_keys, dataname)
      keys <- private$join_keys[dataname, dataname]
      if (is.null(keys)) keys <- character(0)

      if (length(parent_dataname) == 0) {
        private$filtered_datasets[[dataname]] <- init_filtered_dataset(
          dataset = data,
          dataname = dataname,
          keys = keys
        )
      } else {
        join_keys <- private$join_keys[dataname, parent_dataname]
        if (is.null(join_keys)) join_keys <- character(0)
        private$filtered_datasets[[dataname]] <- init_filtered_dataset(
          dataset = data,
          dataname = dataname,
          keys = keys,
          parent_name = parent_dataname,
          parent = reactive(self$get_data(parent_dataname, filtered = TRUE)),
          join_keys = join_keys
        )
      }

      invisible(self)
    },

    #' @description
    #' Set the `join_keys`.
    #'
    #' @param join_keys (`join_keys`), see [`teal.data::join_keys()`].
    #'
    #' @return `self`, invisibly.
    #'
    set_join_keys = function(join_keys) {
      checkmate::assert_class(join_keys, "join_keys")
      private$join_keys <- join_keys
      invisible(self)
    },

    # Functions useful for restoring from another dataset ----

    #' @description
    #' Gets states of all contained `FilterState` objects.
    #'
    #' @return A `teal_slices` object.
    #'
    get_filter_state = function() {
      states <- unname(lapply(private$filtered_datasets, function(x) x$get_filter_state()))
      slices <- Filter(Negate(is.null), states)
      slices <- do.call(c, slices)
      if (!is.null(slices)) {
        attr(slices, "allow_add") <- private$allow_add
      }
      slices
    },

    #' @description
    #' Returns a formatted string representing this `FilteredData` object.
    #'
    #' @param show_all (`logical(1)`) passed to `format.teal_slice`.
    #' @param trim_lines (`logical(1)`) passed to `format.teal_slice`.
    #'
    #' @return `character(1)` the formatted string.
    #'
    format = function(show_all = FALSE, trim_lines = TRUE) {
      datasets <- lapply(self$datanames(), private$get_filtered_dataset)
      ind <- vapply(datasets, inherits, logical(1L), what = "DefaultFilteredDataset")
      states <- do.call(c, lapply(datasets[!ind], function(ds) ds$get_filter_state()))
      states_fmt <- format(states, show_all = show_all, trim_lines = trim_lines)
      holders_fmt <- vapply(datasets[ind], format, character(1L), show_all = show_all, trim_lines = trim_lines)

      sprintf(
        "%s:\n%s",
        class(self)[1],
        paste(c(states_fmt, holders_fmt), collapse = "\n")
      )
    },

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

    #' @description
    #' Sets active filter states.
    #'
    #' @param state (`teal_slices`)
    #'
    #' @return `NULL`, invisibly.
    set_filter_state = function(state) {
      isolate({
        logger::log_debug("{ class(self)[1] }$set_filter_state initializing")
        checkmate::assert_class(state, "teal_slices")
        allow_add <- attr(state, "allow_add")
        if (!is.null(allow_add)) {
          private$allow_add <- allow_add
        }

        lapply(self$datanames(), function(dataname) {
          states <- Filter(function(x) identical(x$dataname, dataname), state)
          private$get_filtered_dataset(dataname)$set_filter_state(states)
        })

        invisible(NULL)
      })

      invisible(NULL)
    },

    #' @description
    #' Removes one or more `FilterState` from a `FilteredData` object.
    #'
    #' @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) {
      isolate({
        checkmate::assert_class(state, "teal_slices")
        state_ids <- unique(vapply(state, "[[", character(1L), "id"))
        logger::log_debug("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { state_ids }")
        datanames <- unique(vapply(state, "[[", character(1L), "dataname"))
        checkmate::assert_subset(datanames, self$datanames())
        lapply(datanames, function(dataname) {
          slices <- Filter(function(x) identical(x$dataname, dataname), state)
          private$get_filtered_dataset(dataname)$remove_filter_state(slices)
        })
      })

      invisible(NULL)
    },

    #' @description
    #' Remove all `FilterStates` of a `FilteredDataset` or all `FilterStates` of a `FilteredData` object.
    #'
    #' @param datanames (`character`)
    #'   names of datasets for which to remove all filter states.
    #'   Defaults to all datasets in this `FilteredData` object.
    #' @param force (`logical(1)`)
    #'   flag specifying whether to include anchored filter states.
    #'
    #' @return `NULL`, invisibly.
    #'
    clear_filter_states = function(datanames = self$datanames(), force = FALSE) {
      logger::log_debug("FilteredData$clear_filter_states called, datanames: { toString(datanames) }")
      for (dataname in datanames) {
        fdataset <- private$get_filtered_dataset(dataname = dataname)
        fdataset$clear_filter_states(force)
      }
      invisible(NULL)
    },


    # shiny modules -----

    #' @description
    #' top-level `shiny` module for the filter panel in the `teal` app.
    #' Contains 1) filter overview panel, 2) filter active panel, and 3) add filters panel.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param active_datanames (`reactive`)
    #'   defining subset of `self$datanames()` to be displayed.
    #' @return `shiny.tag`
    ui_filter_panel = function(id, active_datanames = self$datanames) {
      ns <- NS(id)
      bslib::page_fluid(
        id = ns(NULL), # used for hiding / showing
        class = "teal-slice filter-panel",
        include_css_files(pattern = "filter-panel"),
        include_js_files(pattern = "togglePanelItems"),
        shinyjs::useShinyjs(),
        self$ui_overview(ns("overview")),
        self$ui_active(ns("active"), active_datanames = active_datanames)
      )
    },

    #' @description
    #' Server function for filter panel.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param active_datanames (`function` or `reactive`)
    #'   returning `datanames` that should be shown on the filter panel.
    #'   Must be a subset of the `datanames` in this `FilteredData`.
    #'   If the function returns `NULL` (as opposed to `character(0)`),
    #'   the filter panel will be hidden.
    #' @return `NULL`.
    srv_filter_panel = function(id, active_datanames = self$datanames) {
      checkmate::assert_function(active_datanames)
      moduleServer(id = id, function(input, output, session) {
        logger::log_debug("FilteredData$srv_filter_panel initializing")

        active_datanames_resolved <- reactive({
          checkmate::assert_subset(active_datanames(), self$datanames())
          active_datanames()
        })

        self$srv_overview("overview", active_datanames_resolved)
        self$srv_active("active", active_datanames_resolved)

        NULL
      })
    },

    #' @description
    #' Server module responsible for displaying active filters.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param active_datanames (`reactive`)
    #'   defining subset of `self$datanames()` to be displayed.
    #' @return `shiny.tag`
    ui_active = function(id, active_datanames = self$datanames) {
      ns <- NS(id)
      tags$div(
        id = id, # not used, can be used to customize CSS behavior
        include_js_files(pattern = "togglePanelItems"),
        class = "teal-slice",
        bslib::accordion(
          id = ns("main_filter_accordian"),
          bslib::accordion_panel(
            "Filter Data",
            tags$div(
              div(
                id = ns("additional_filter_helpers"),
                class = "teal-slice available-filters",
                private$ui_available_filters(ns("available_filters")),
                uiOutput(ns("remove_all_filters_ui"))
              ),
              tags$div(
                id = ns("filter_active_vars_contents"),
                tagList(
                  lapply(
                    isolate(active_datanames()),
                    function(dataname) {
                      fdataset <- private$get_filtered_dataset(dataname)
                      fdataset$ui_active(id = ns(dataname), allow_add = private$allow_add)
                    }
                  )
                )
              ),
              tags$div(
                id = ns("filters_active_count"),
                style = "display: none;",
                textOutput(ns("teal_filters_count"))
              )
            )
          )
        ),
        tags$script(
          HTML(
            sprintf(
              "
            $(document).ready(function() {
              $('#%s').appendTo('#%s > .accordion-item > .accordion-header');
              $('#%s > .accordion-item > .accordion-header').css({
                'display': 'flex'
              });
              $('#%s i').css({
                'color': 'var(--bs-accordion-color)',
                'font-size': '1rem'
              });
            });
          ",
              ns("additional_filter_helpers"),
              ns("main_filter_accordian"),
              ns("main_filter_accordian"),
              ns("additional_filter_helpers")
            )
          )
        )
      )
    },

    #' @description
    #' Server module responsible for displaying active filters.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param active_datanames (`reactive`)
    #'   defining subset of `self$datanames()` to be displayed.
    #' @return `NULL`.
    srv_active = function(id, active_datanames = self$datanames) {
      checkmate::assert_function(active_datanames)
      moduleServer(id, function(input, output, session) {
        logger::log_debug("FilteredData$srv_active initializing")

        private$srv_available_filters("available_filters")

        private$session_bindings[[session$ns("minimise_filter_active")]] <- observeEvent(
          eventExpr = input$minimise_filter_active,
          handlerExpr = {
            shinyjs::toggle("filter_active_vars_contents")
            shinyjs::toggle("filters_active_count")
            toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"))
            toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"))
          }
        )

        filter_count <- reactive({
          length(self$get_filter_state())
        })

        is_filter_removable <- reactive({
          non_anchored <- Filter(function(x) !x$anchored, self$get_filter_state())
          isTRUE(length(non_anchored) > 0)
        })

        output$remove_all_filters_ui <- renderUI({
          req(is_filter_removable())
          tags$div(
            style = "display: flex;",
            actionLink(
              inputId = session$ns("remove_all_filters"),
              label = "",
              title = "Remove active filters",
              icon = icon("far fa-circle-xmark"),
              class = "teal-slice filter-icon remove-all"
            )
          )
        })

        private$session_bindings[[session$ns("is_filter_removable")]] <- observeEvent(
          eventExpr = is_filter_removable(),
          handlerExpr = {
            shinyjs::toggle("remove_all_filters", condition = is_filter_removable())
            shinyjs::show("filter_active_vars_contents")
            shinyjs::hide("filters_active_count")
            toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"), TRUE)
            toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"), TRUE)
          }
        )

        private$session_bindings[[session$ns("active_datanames")]] <- observeEvent(
          eventExpr = active_datanames(),
          handlerExpr = lapply(self$datanames(), function(dataname) {
            if (dataname %in% active_datanames()) {
              shinyjs::show(dataname)
            } else {
              shinyjs::hide(dataname)
            }
          })
        )

        # should not use for-loop as variables are otherwise only bound by reference
        # and last dataname would be used
        lapply(
          self$datanames(),
          function(dataname) {
            fdataset <- private$get_filtered_dataset(dataname)
            fdataset$srv_active(id = dataname)
          }
        )

        output$teal_filters_count <- renderText({
          n_filters_active <- filter_count()
          req(n_filters_active > 0L)
          sprintf(
            "%s filter%s applied across datasets",
            n_filters_active,
            ifelse(n_filters_active == 1, "", "s")
          )
        })

        private$session_bindings[[session$ns("remove_all_filters")]] <- observeEvent(
          eventExpr = input$remove_all_filters,
          handlerExpr = {
            logger::log_debug("FilteredData$srv_filter_panel@1 removing all non-anchored filters")
            self$clear_filter_states()
          }
        )

        private$session_bindings[[session$ns("inputs")]] <- list(
          destroy = function() {
            lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
          }
        )

        NULL
      })
    },

    #' @description
    #' Creates the UI definition for the module showing counts for each dataset
    #' contrasting the filtered to the full unfiltered dataset.
    #'
    #' Per dataset, it displays
    #' the number of rows/observations in each dataset,
    #' the number of unique subjects.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    ui_overview = function(id) {
      ns <- NS(id)
      tags$div(
        class = "teal-slice",
        bslib::accordion(
          id = ns("main_filter_accordian"),
          bslib::accordion_panel(
            title = "Active Filter Summary",
            tags$div(
              id = ns("filters_overview_contents"),
              tags$div(
                class = "teal_active_summary_filter_panel",
                tableOutput(ns("table"))
              )
            )
          )
        )
      )
    },

    #' @description
    #' Server function to display the number of records in the filtered and unfiltered
    #' data.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param active_datanames (`reactive`)
    #'   returning `datanames` that should be shown on the filter panel,
    #'   must be a subset of the `datanames` argument provided to `ui_filter_panel`;
    #'   if the function returns `NULL` (as opposed to `character(0)`), the filter
    #'   panel will be hidden.
    #' @return `NULL`.
    srv_overview = function(id, active_datanames = self$datanames) {
      checkmate::assert_class(active_datanames, "reactive")
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("FilteredData$srv_filter_overview initializing")

          output$table <- renderUI({
            logger::log_debug("FilteredData$srv_filter_overview@1 updating counts")
            if (length(active_datanames()) == 0) {
              return(NULL)
            }

            datasets_df <- self$get_filter_overview(datanames = active_datanames())

            attr(datasets_df$dataname, "label") <- "Data Name"

            if (!is.null(datasets_df$obs)) {
              # some datasets (MAE colData) doesn't return obs column
              datasets_df <- transform(
                datasets_df,
                obs_str_summary = ifelse(
                  !is.na(obs),
                  sprintf("%s/%s", obs_filtered, obs),
                  ""
                )
              )
              attr(datasets_df$obs_str_summary, "label") <- "Obs"
            }


            if (!is.null(datasets_df$subjects)) {
              # some datasets (without keys) doesn't return subjects
              datasets_df <- transform(
                datasets_df,
                subjects_summary = ifelse(
                  !is.na(subjects),
                  sprintf("%s/%s", subjects_filtered, subjects),
                  ""
                )
              )
              attr(datasets_df$subjects_summary, "label") <- "Subjects"
            }

            all_names <- c("dataname", "obs_str_summary", "subjects_summary")
            datasets_df <- datasets_df[, colnames(datasets_df) %in% all_names]

            body_html <- apply(
              datasets_df,
              1,
              function(x) {
                tags$tr(
                  tagList(
                    tags$td(
                      if (all(x[-1] == "")) {
                        icon(
                          name = "exclamation-triangle",
                          title = "Unsupported dataset",
                          `data-container` = "body",
                          `data-toggle` = "popover",
                          `data-content` = "object not supported by the filter panel"
                        )
                      },
                      x[1]
                    ),
                    lapply(x[-1], tags$td)
                  )
                )
              }
            )

            header_labels <- vapply(
              seq_along(datasets_df),
              function(i) {
                label <- attr(datasets_df[[i]], "label")
                ifelse(!is.null(label), label, names(datasets_df)[[i]])
              },
              character(1)
            )
            header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))

            table_html <- tags$table(
              class = "table custom-table",
              tags$thead(header_html),
              tags$tbody(body_html)
            )
            table_html
          })

          NULL
        }
      )
    },

    #' @description
    #' Object and dependencies cleanup.
    #'
    #' - Destroy inputs and observers stored in `private$session_bindings`
    #' - Finalize `FilteredData` stored in `private$filtered_datasets`
    #'
    #' @return `NULL`, invisibly.
    finalize = function() {
      .finalize_session_bindings(self, private)
      lapply(private$filtered_datasets, function(x) x$finalize())
      invisible(NULL)
    }
  ),

  # private members ----
  private = list(
    # selectively hide / show to only show `active_datanames` out of all datanames

    # private attributes ----
    filtered_datasets = list(),

    # activate/deactivate filter panel
    filter_panel_active = TRUE,

    # `reactive` containing teal_slices that can be selected; only active in module-specific mode
    available_teal_slices = NULL,

    # keys used for joining/filtering data a join_keys object (see teal.data)
    join_keys = NULL,

    # flag specifying whether the user may add filters
    allow_add = TRUE,

    # observers and inputs list
    session_bindings = list(),

    # private methods ----

    # @description
    # Gets `FilteredDataset` object which contains all information
    # pertaining to the specified dataset.
    #
    # @param dataname (`character(1)`)
    #   name of the dataset
    #
    # @return `FilteredDataset` object or list of `FilteredDataset`s
    #
    get_filtered_dataset = function(dataname = character(0)) {
      if (length(dataname) == 0) {
        private$filtered_datasets
      } else {
        private$filtered_datasets[[dataname]]
      }
    },

    # @description
    # Activate available filters.
    # Module is composed from plus button and dropdown menu. Menu is shown when
    # the button is clicked. Menu contains available/active filters list
    # passed via `set_available_teal_slice`.
    ui_available_filters = function(id) {
      ns <- NS(id)

      active_slices_id <- isolate(vapply(self$get_filter_state(), `[[`, character(1), "id"))
      tags$div(
        id = ns("available_menu"),
        shinyWidgets::dropMenu(
          tags$a(
            id = ns("show"),
            class = "available-menu",
            bsicons::bs_icon("plus-square", size = "1.4rem", class = "teal-slice filter-icon"),
          ),
          tags$div(
            class = "menu-content",
            shinycssloaders::withSpinner(
              uiOutput(ns("checkbox")),
              type = 4,
              size = 0.25
            )
          )
        )
      )
    },
    # @description
    # Activate available filters. When a filter is selected or removed,
    # `set_filter_state` or `remove_filter_state` is executed for
    # the appropriate filter state id.
    srv_available_filters = function(id) {
      moduleServer(id, function(input, output, session) {
        slices_available <- self$get_available_teal_slices()
        slices_interactive <- reactive(
          Filter(function(slice) isFALSE(slice$fixed), slices_available())
        )
        slices_fixed <- reactive(
          Filter(function(slice) isTRUE(slice$fixed), slices_available())
        )
        available_slices_id <- reactive(vapply(slices_available(), `[[`, character(1), "id"))
        active_slices_id <- reactive(vapply(self$get_filter_state(), `[[`, character(1), "id"))
        duplicated_slice_references <- reactive({
          # slice refers to a particular column
          slice_reference <- vapply(slices_available(), get_default_slice_id, character(1))
          is_duplicated_reference <- duplicated(slice_reference) | duplicated(slice_reference, fromLast = TRUE)
          is_active <- available_slices_id() %in% active_slices_id()
          is_not_expr <- !vapply(slices_available(), inherits, logical(1), "teal_slice_expr")
          slice_reference[is_duplicated_reference & is_active & is_not_expr]
        })

        checkbox_group_element <- function(name, value, label, checked, disabled = FALSE) {
          tags$div(
            class = "checkbox available-filters",
            tags$label(
              tags$input(
                type = "checkbox",
                name = name,
                value = value,
                checked = checked,
                disabled = if (disabled) "disabled"
              ),
              tags$span(label, disabled = if (disabled) disabled)
            )
          )
        }

        output$checkbox <- renderUI({
          checkbox <- checkboxGroupInput(
            session$ns("available_slices_id"),
            label = NULL,
            choices = NULL,
            selected = NULL
          )
          active_slices_ids <- active_slices_id()
          duplicated_slice_refs <- duplicated_slice_references()

          checkbox_group_slice <- function(slice) {
            # we need to isolate changes in the fields of the slice (teal_slice)
            isolate({
              checkbox_group_element(
                name = session$ns("available_slices_id"),
                value = slice$id,
                label = slice$id,
                checked = if (slice$id %in% active_slices_ids) "checked",
                disabled = slice$anchored ||
                  get_default_slice_id(slice) %in% duplicated_slice_refs &&
                    !slice$id %in% active_slices_ids
              )
            })
          }

          interactive_choice_mock <- lapply(slices_interactive(), checkbox_group_slice)
          non_interactive_choice_mock <- lapply(slices_fixed(), checkbox_group_slice)

          htmltools::tagInsertChildren(
            checkbox,
            tags$br(),
            if (length(non_interactive_choice_mock)) tags$strong("Fixed filters"),
            non_interactive_choice_mock,
            if (length(interactive_choice_mock)) tags$strong("Interactive filters"),
            interactive_choice_mock,
            .cssSelector = "div.shiny-options-group",
            after = 0
          )
        })

        private$session_bindings[[session$ns("available_slices_id")]] <- observeEvent(
          eventExpr = input$available_slices_id,
          ignoreNULL = FALSE,
          ignoreInit = TRUE,
          handlerExpr = {
            new_slices_id <- setdiff(input$available_slices_id, active_slices_id())
            removed_slices_id <- setdiff(active_slices_id(), input$available_slices_id)
            if (length(new_slices_id)) {
              new_teal_slices <- Filter(
                function(slice) slice$id %in% new_slices_id,
                private$available_teal_slices()
              )
              self$set_filter_state(new_teal_slices)
            }

            if (length(removed_slices_id)) {
              removed_teal_slices <- Filter(
                function(slice) slice$id %in% removed_slices_id,
                self$get_filter_state()
              )
              self$remove_filter_state(removed_teal_slices)
            }
          }
        )

        private$session_bindings[[session$ns("available_teal_slices")]] <- observeEvent(
          eventExpr = private$available_teal_slices(),
          ignoreNULL = FALSE,
          handlerExpr = {
            if (length(private$available_teal_slices())) {
              shinyjs::show("available_menu")
            } else {
              shinyjs::hide("available_menu")
            }
          }
        )
      })
    }
  )
)

# RangeFilterState ------

#' @name RangeFilterState
#' @docType class
#'
#' @title `FilterState` object for numeric data
#'
#' @description Manages choosing a numeric range.
#'
#' @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")
#' RangeFilterState <- getFromNamespace("RangeFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- RangeFilterState$new(
#'   x = c(NA, Inf, seq(1:10)),
#'   slice = teal_slice(varname = "x", dataname = "data")
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#'   teal_slice(
#'     dataname = "data",
#'     varname = "x",
#'     selected = c(3L, 8L),
#'     keep_na = TRUE,
#'     keep_inf = TRUE
#'   )
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' data_range <- c(runif(100, 0, 1), NA, Inf)
#' fs <- RangeFilterState$new(
#'   x = data_range,
#'   slice = teal_slice(
#'     dataname = "data",
#'     varname = "x",
#'     selected = c(0.15, 0.93),
#'     keep_na = TRUE,
#'     keep_inf = TRUE
#'   )
#' )
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   column(4, tags$div(
#'     tags$h4("RangeFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, tags$div(
#'     id = "outputs", # div id is needed for toggling the element
#'     tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_range"), tags$br(),
#'     tags$h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_range"), tags$br(),
#'     tags$h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_range"), tags$br()
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Programmatic filter control"),
#'     actionButton("button1_range", "set drop NA", width = "100%"), tags$br(),
#'     actionButton("button2_range", "set keep NA", width = "100%"), tags$br(),
#'     actionButton("button3_range", "set drop Inf", width = "100%"), tags$br(),
#'     actionButton("button4_range", "set keep Inf", width = "100%"), tags$br(),
#'     actionButton("button5_range", "set a range", width = "100%"), tags$br(),
#'     actionButton("button6_range", "set full range", width = "100%"), tags$br(),
#'     actionButton("button0_range", "set initial state", width = "100%"), tags$br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_range <- renderPrint(fs$get_call())
#'   output$formatted_range <- renderText(fs$format())
#'   output$unformatted_range <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = FALSE))
#'   )
#'   observeEvent(
#'     input$button4_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = TRUE))
#'   )
#'   observeEvent(
#'     input$button5_range,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = c(0.2, 0.74))
#'     )
#'   )
#'   observeEvent(
#'     input$button6_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", selected = c(0, 1)))
#'   )
#'   observeEvent(
#'     input$button0_range,
#'     fs$set_state(
#'       teal_slice("data", "variable", selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @keywords internal
#'
RangeFilterState <- R6::R6Class( # nolint
  "RangeFilterState",
  inherit = FilterState,

  # public methods ----
  public = list(

    #' @description
    #' Initialize a `FilterState` object for range selection.
    #' @param x (`numeric`)
    #'   variable to be filtered.
    #' @param x_reactive (`reactive`)
    #'   returning vector of the same type as `x`. Is used to update
    #'   counts following the change in values of the filtered dataset.
    #'   If it is set to `reactive(NULL)` then counts based on filtered
    #'   dataset are not shown.
    #' @param slice (`teal_slice`)
    #'   specification of this filter state.
    #'   `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
    #'   `get_state` returns `teal_slice` object which can be reused in other places.
    #'   Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
    #'   changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
    #' @param extract_type (`character`)
    #'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
    #' - `character(0)` (default) `varname` in the condition call will not be prefixed
    #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
    #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
    #'
    #' @return Object of class `RangeFilterState`, invisibly.
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          extract_type = character(0),
                          slice) {
      isolate({
        checkmate::assert_numeric(x, all.missing = FALSE)
        if (!any(is.finite(x))) stop("\"x\" contains no finite values")
        super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type)
        private$is_integer <- checkmate::test_integerish(x)
        private$inf_count <- sum(is.infinite(x))
        private$inf_filtered_count <- reactive(
          if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive()))
        )

        checkmate::assert_numeric(slice$choices, null.ok = TRUE)
        if (is.null(slice$keep_inf) && any(is.infinite(x))) slice$keep_inf <- TRUE

        private$set_choices(slice$choices)
        if (is.null(slice$selected)) slice$selected <- slice$choices
        private$set_selected(slice$selected)

        private$is_integer <- checkmate::test_integerish(x)
        private$inf_filtered_count <- reactive(
          if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive()))
        )
        private$inf_count <- sum(is.infinite(x))

        private$plot_data <- list(
          type = "histogram",
          nbinsx = 50,
          x = Filter(Negate(is.na), Filter(is.finite, private$x)),
          color = I(fetch_bs_color("secondary")),
          alpha = 0.2,
          bingroup = 1,
          showlegend = FALSE,
          hoverinfo = "none"
        )
        private$plot_mask <- list(list(
          type = "rect", fillcolor = rgb(1, 1, 1, .65), line = list(width = 0),
          x0 = -0.5, x1 = 1.5, y0 = -0.5, y1 = 1.5, xref = "paper", yref = "paper"
        ))
        private$plot_layout <- reactive({
          shapes <- private$get_shape_properties(private$get_selected())
          list(
            barmode = "overlay",
            xaxis = list(
              range = private$get_choices() * c(0.995, 1.005),
              rangeslider = list(thickness = 0),
              showticklabels = TRUE,
              ticks = "outside",
              ticklen = 1.5,
              tickmode = "auto",
              nticks = 10
            ),
            yaxis = list(showgrid = FALSE, showticklabels = FALSE),
            margin = list(b = 17, l = 0, r = 0, t = 0, autoexpand = FALSE),
            plot_bgcolor = "#FFFFFF00",
            paper_bgcolor = "#FFFFFF00",
            shapes = shapes
          )
        })
        private$plot_config <- reactive({
          list(
            doubleClick = "reset",
            displayModeBar = FALSE,
            edits = list(shapePosition = TRUE)
          )
        })
        private$plot_filtered <- reactive({
          finite_values <- Filter(is.finite, private$x_reactive())
          if (!identical(finite_values, numeric(0))) {
            list(
              x = finite_values,
              bingroup = 1,
              color = I(fetch_bs_color("primary"))
            )
          }
        })
        invisible(self)
      })
    },

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For this class returned call looks like
    #' `<varname> >= <min value> & <varname> <= <max value>` with
    #' optional `is.na(<varname>)` and `is.finite(<varname>)`.
    #' @param dataname name of data set; defaults to `private$get_dataname()`
    #' @return `call`
    #'
    get_call = function(dataname) {
      if (isFALSE(private$is_any_filtered())) {
        return(NULL)
      }
      if (missing(dataname)) dataname <- private$get_dataname()
      varname <- private$get_varname_prefixed(dataname)
      filter_call <-
        call(
          "&",
          call(">=", varname, private$get_selected()[1L]),
          call("<=", varname, private$get_selected()[2L])
        )
      private$add_keep_na_call(private$add_keep_inf_call(filter_call, varname), varname)
    },

    #' @description
    #' Returns current `keep_inf` selection.
    #' @return `logical(1)`
    get_keep_inf = function() {
      private$teal_slice$keep_inf
    }
  ),

  # private fields----
  private = list(
    inf_count = integer(0),
    inf_filtered_count = NULL,
    is_integer = logical(0),
    numeric_step = numeric(0), # step for the slider input widget, calculated from input data (x)
    plot_data = NULL,
    plot_mask = list(),
    plot_layout = NULL,
    plot_config = NULL,
    plot_filtered = NULL,

    # private methods ----

    set_choices = function(choices) {
      x <- private$x[is.finite(private$x)]
      if (is.null(choices)) {
        choices <- range(x)
      } else {
        choices_adjusted <- c(max(choices[1L], min(x)), min(choices[2L], max(x)))
        if (any(choices != choices_adjusted)) {
          warning(sprintf(
            "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",
            private$get_varname(), private$get_dataname()
          ))
          choices <- choices_adjusted
        }
        if (choices[1L] > choices[2L]) {
          warning(sprintf(
            "Invalid choices: lower is higher / equal to upper, or not in range of variable values.
            Setting defaults. Varname: %s, dataname: %s.",
            private$get_varname(), private$get_dataname()
          ))
          choices <- range(x)
        }
      }

      private$set_is_choice_limited(private$x, choices)
      private$x <- private$x[
        (private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x) | !is.finite(private$x)
      ]

      x_range <- range(private$x, finite = TRUE)

      # Required for displaying ticks on the slider, can modify choices!
      if (identical(diff(x_range), 0)) {
        choices <- x_range
      } else {
        x_pretty <- pretty(x_range, 100L)
        choices <- range(x_pretty)
        private$numeric_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10)
      }
      private$teal_slice$choices <- choices
      invisible(NULL)
    },

    # @description
    # Check whether the initial choices filter out some values of x and set the flag in case.
    set_is_choice_limited = function(xl, choices) {
      xl <- xl[!is.na(xl)]
      xl <- xl[is.finite(xl)]
      private$is_choice_limited <- (any(xl < choices[1L]) | any(xl > choices[2L]))
      invisible(NULL)
    },

    # Adds is.infinite(varname) before existing condition calls if keep_inf is selected
    # returns a call
    add_keep_inf_call = function(filter_call, varname) {
      if (isTRUE(private$get_keep_inf())) {
        call("|", call("is.infinite", varname), filter_call)
      } else {
        filter_call
      }
    },

    # @description gets pretty step size for range slider
    #  adaptation of shiny's method (see shiny/R/input-slider.R function findStepSize)
    # @param pretty_range (numeric(n)) vector of pretty values
    # @return numeric(1) pretty step size for the sliderInput
    get_pretty_range_step = function(pretty_range) {
      if (private$is_integer && diff(range(pretty_range) > 2)) {
        return(1L)
      } else {
        n_steps <- length(pretty_range) - 1
        return(signif(digits = 10, (max(pretty_range) - min(pretty_range)) / n_steps))
      }
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.numeric(values)
          if (anyNA(values)) stop()
          values
        },
        error = function(e) stop("Vector of set values must contain values coercible to numeric")
      )
    },
    # Also validates that selection is sorted.
    check_length = function(values) {
      if (length(values) != 2L) stop("Vector of set values must have length two.")
      if (values[1L] > values[2L]) stop("Vector of set values must be sorted.")
      values
    },
    # Trim selection to limits imposed by private$get_choices()
    remove_out_of_bounds_values = function(values) {
      if (values[1L] < private$get_choices()[1L]) values[1L] <- private$get_choices()[1L]
      if (values[2L] > private$get_choices()[2L]) values[2L] <- private$get_choices()[2L]
      values
    },

    # Answers the question of whether the current settings and values selected actually filters out any values.
    # @return logical scalar
    is_any_filtered = function() {
      if (private$is_choice_limited) {
        TRUE
      } else if (!isTRUE(all.equal(private$get_selected(), private$get_choices()))) {
        TRUE
      } else if (!isTRUE(private$get_keep_inf()) && private$inf_count > 0) {
        TRUE
      } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
        TRUE
      } else {
        FALSE
      }
    },

    # obtain shape determination for histogram
    # returns a list that is passed to plotly's layout.shapes property
    get_shape_properties = function(values) {
      list(
        list(type = "line", x0 = values[1], x1 = values[1], y0 = -100, y1 = 100, yref = "paper"),
        list(type = "line", x0 = values[2], x1 = values[2], y0 = -100, y1 = 100, yref = "paper")
      )
    },

    # shiny modules ----

    # UI Module for `RangeFilterState`.
    # This UI element contains two values for `min` and `max`
    # of the range and two checkboxes whether to keep the `NA` or `Inf`  values.
    # @param id (`character(1)`) `shiny` module instance id.
    ui_inputs = function(id) {
      ns <- NS(id)
      isolate({
        ui_input <- shinyWidgets::numericRangeInput(
          inputId = ns("selection_manual"),
          label = NULL,
          min = private$get_choices()[1L],
          max = private$get_choices()[2L],
          value = private$get_selected(),
          step = private$numeric_step,
          width = "100%"
        )
        tagList(
          tags$div(
            class = "choices_state",
            tags$head(tags$script(
              # Inline JS code for popover functionality.
              # Adding the script inline because when added from a file with include_js_files(),
              # it only works in the first info_button instance and not others.
              HTML(
                '$(document).ready(function() {
                  $("[data-toggle=\'popover\']").popover();

                  $(document).on("click", function (e) {
                    if (!$("[data-toggle=\'popover\']").is(e.target) &&
                        $("[data-toggle=\'popover\']").has(e.target).length === 0 &&
                        $(".popover").has(e.target).length === 0) {
                      $("[data-toggle=\'popover\']").popover("hide");
                    }
                  });
                });'
              )
            )),
            tags$div(
              actionLink(
                ns("plotly_info"),
                label = NULL,
                icon = icon("question-circle"),
                "data-toggle" = "popover",
                "data-html" = "true",
                "data-placement" = "left",
                "data-trigger" = "click",
                "data-title" = "Plot actions",
                "data-content" = "<p>
                                  Drag vertical lines to set selection.<br>
                                  Drag across plot to zoom in.<br>
                                  Drag axis to pan.<br>
                                  Double click to zoom out."
              ),
              style = "text-align: right; font-size: 0.7em; margin-bottom: -1em; position: relative; z-index: 9;"
            ),
            shinycssloaders::withSpinner(
              plotly::plotlyOutput(ns("plot"), height = "50px"),
              type = 4,
              size = 0.25,
              hide.ui = FALSE
            ),
            ui_input
          ),
          tags$div(
            class = "filter-card-body-keep-na-inf",
            private$keep_inf_ui(ns("keep_inf")),
            private$keep_na_ui(ns("keep_na"))
          )
        )
      })
    },

    # @description
    # Server module
    # @param id (`character(1)`) `shiny` module instance id.
    # return `NULL`.
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("RangeFilterState$server initializing, id: { private$get_id() }")

          # Capture manual input with debounce.
          selection_manual <- debounce(reactive(input$selection_manual), 200)

          # Prepare for histogram construction.
          plot_data <- c(private$plot_data, source = session$ns("histogram_plot"))

          trigger_event_data <- reactiveVal(NULL)

          # Display histogram, adding a second trace that contains filtered data.
          output$plot <- plotly::renderPlotly({
            histogram <- do.call(plotly::plot_ly, plot_data)
            histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout()))
            histogram <- do.call(plotly::config, c(list(p = histogram), private$plot_config()))
            histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered()))
            trigger_event_data(TRUE)
            histogram
          })

          relayout_data <- reactive({
            req(trigger_event_data())
            plotly::event_data("plotly_relayout", source = session$ns("histogram_plot"))
          })

          # Dragging shapes (lines) on plot updates selection.
          private$session_bindings[[session$ns("relayout")]] <- observeEvent(
            ignoreNULL = FALSE,
            ignoreInit = TRUE,
            eventExpr = relayout_data(),
            handlerExpr = {
              logger::log_debug("RangeFilterState$server@1 selection changed, id: { private$get_id() }")
              event <- relayout_data()
              if (any(grepl("shapes", names(event)))) {
                line_positions <- private$get_selected()
                if (any(grepl("shapes[0]", names(event), fixed = TRUE))) {
                  line_positions[1] <- event[["shapes[0].x0"]]
                } else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) {
                  line_positions[2] <- event[["shapes[1].x0"]]
                }
                # If one line was dragged past the other, abort action and reset lines.
                if (line_positions[1] > line_positions[2]) {
                  showNotification(
                    "Numeric range start value must be less than end value.",
                    type = "warning"
                  )
                  plotly::plotlyProxyInvoke(
                    plotly::plotlyProxy("plot"),
                    "relayout",
                    shapes = private$get_shape_properties(private$get_selected())
                  )
                  return(NULL)
                }

                private$set_selected(signif(line_positions, digits = 4L))
              }
            }
          )

          # Change in selection updates shapes (lines) on plot and numeric input.
          private$session_bindings[[session$ns("selection_api")]] <- observeEvent(
            ignoreNULL = FALSE,
            ignoreInit = TRUE,
            eventExpr = private$get_selected(),
            handlerExpr = {
              if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) {
                logger::log_debug("RangeFilterState$server@2 state changed, id: {private$get_id() }")
                shinyWidgets::updateNumericRangeInput(
                  session = session,
                  inputId = "selection_manual",
                  value = private$get_selected()
                )
              }
            }
          )

          # Manual input updates selection.
          private$session_bindings[[session$ns("selection_manual")]] <- observeEvent(
            ignoreNULL = FALSE,
            ignoreInit = TRUE,
            eventExpr = selection_manual(),
            handlerExpr = {
              selection <- selection_manual()
              # Abort and reset if non-numeric values is entered.
              if (any(is.na(selection))) {
                showNotification(
                  "Numeric range values must be numbers.",
                  type = "warning"
                )
                shinyWidgets::updateNumericRangeInput(
                  session = session,
                  inputId = "selection_manual",
                  value = private$get_selected()
                )
                return(NULL)
              }

              # Abort and reset if reversed choices are specified.
              if (selection[1] > selection[2]) {
                showNotification(
                  "Numeric range start value must be less than end value.",
                  type = "warning"
                )
                shinyWidgets::updateNumericRangeInput(
                  session = session,
                  inputId = "selection_manual",
                  value = private$get_selected()
                )
                return(NULL)
              }


              if (!isTRUE(all.equal(selection, private$get_selected()))) {
                logger::log_debug("RangeFilterState$server@3 manual selection changed, id: { private$get_id() }")
                private$set_selected(selection)
              }
            }
          )

          private$keep_inf_srv("keep_inf")
          private$keep_na_srv("keep_na")

          NULL
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("RangeFilterState$server initializing, id: { private$get_id() }")

          plot_config <- private$plot_config()
          plot_config$staticPlot <- TRUE

          output$plot <- plotly::renderPlotly({
            histogram <- do.call(plotly::plot_ly, private$plot_data)
            histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout()))
            histogram <- do.call(plotly::config, c(list(p = histogram), plot_config))
            histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered()))
            histogram
          })

          output$selection <- renderUI({
            shinycssloaders::withSpinner(
              plotly::plotlyOutput(session$ns("plot"), height = "50px"),
              type = 4,
              size = 0.25
            )
          })

          NULL
        }
      )
    },

    # @description
    # Server module to display filter summary
    #  renders text describing selected range and
    #  if NA or Inf are included also
    # @return `shiny.tag` to include in the `ui_summary`
    content_summary = function() {
      selection <- private$get_selected()
      tagList(
        tags$span(HTML(selection[1], "&ndash;", selection[2]), class = "filter-card-summary-value"),
        tags$span(
          class = "filter-card-summary-controls",
          if (private$na_count > 0) {
            tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
          },
          if (private$inf_count > 0) {
            tags$span("Inf", if (isTRUE(private$get_keep_inf())) icon("check") else icon("xmark"))
          }
        )
      )
    },

    # @description
    # Module displaying input to keep or remove NA in the `FilterState` call.
    # Renders a checkbox input only when variable with which the `FilterState` has been created contains Infs.
    # @param id (`character(1)`) `shiny` module instance id.
    keep_inf_ui = function(id) {
      ns <- NS(id)

      if (private$inf_count > 0) {
        countmax <- private$na_count
        countnow <- isolate(private$filtered_na_count())
        ui_input <- checkboxInput(
          inputId = ns("value"),
          label = tags$span(
            id = ns("count_label"),
            make_count_text(
              label = "Keep Inf",
              countmax = countmax,
              countnow = countnow
            )
          ),
          value = isolate(private$get_keep_inf())
        )
        tags$div(
          uiOutput(ns("trigger_visible"), inline = TRUE),
          ui_input
        )
      } else {
        NULL
      }
    },

    # @description
    # Module to handle Inf values in the FilterState
    # Sets `private$slice$keep_inf` according to the selection
    # and updates the relevant UI element if `private$slice$keep_inf` has been changed by the api.
    # @param id (`character(1)`) `shiny` module instance id.
    # @return `NULL`.
    keep_inf_srv = function(id) {
      moduleServer(id, function(input, output, session) {
        # 1. renderUI is used here as an observer which triggers only if output is visible
        #  and if the reactive changes - reactive triggers only if the output is visible.
        # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)
        output$trigger_visible <- renderUI({
          updateCountText(
            inputId = "count_label",
            label = "Keep Inf",
            countmax = private$inf_count,
            countnow = private$inf_filtered_count()
          )
          NULL
        })

        # this observer is needed in the situation when private$teal_slice$keep_inf has been
        # changed directly by the api - then it's needed to rerender UI element
        # to show relevant values
        private$session_bindings[[session$ns("keep_inf_api")]] <- observeEvent(
          ignoreNULL = TRUE, # its not possible for range that NULL is selected
          ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
          eventExpr = private$get_keep_inf(),
          handlerExpr = {
            if (!setequal(private$get_keep_inf(), input$value)) {
              logger::log_debug("RangeFilterState$keep_inf_srv@1 changed reactive value, id: { private$get_id() }")
              updateCheckboxInput(
                inputId = "value",
                value = private$get_keep_inf()
              )
            }
          }
        )

        private$session_bindings[[session$ns("keep_inf")]] <- observeEvent(
          ignoreNULL = TRUE, # it's not possible for range that NULL is selected
          ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
          eventExpr = input$value,
          handlerExpr = {
            logger::log_debug("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
            keep_inf <- input$value
            private$set_keep_inf(keep_inf)
          }
        )

        invisible(NULL)
      })
    }
  )
)

#' Compose predicates
#'
#' Combines calls with a logical operator.
#'
#' This function is used to combine logical predicates produced by `FilterState` objects
#' to build a complete subset expression.
#'
#' @param calls (`list`)
#'   containing calls (or symbols) to be combined by `operator`
#' @param operator (`character(1)`)
#'   infix operator to use in predicate composition, _e.g._ `"&"`
#'
#' @return
#' A `call` where elements of `calls` are composed with `operator` or `NULL` if `calls` is an empty list.
#'
#' @examples
#' # use non-exported function from teal.slice
#' calls_combine_by <- getFromNamespace("calls_combine_by", "teal.slice")
#'
#' calls <- list(
#'   quote(SEX == "F"), # subsetting on factor
#'   quote(AGE >= 20 & AGE <= 50), # subsetting on range
#'   quote(!SURV) # subsetting on logical
#' )
#' calls_combine_by(calls, "&")
#'
#' @keywords internal
#'
calls_combine_by <- function(calls, operator) {
  checkmate::assert_list(calls)
  if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
  checkmate::assert_string(operator)

  Reduce(
    x = calls,
    f = function(x, y) call(operator, x, y)
  )
}

.onLoad <- function(libname, pkgname) { # nolint
  # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R
  teal_default_options <- list(teal.threshold_slider_vs_checkboxgroup = 5)
  op <- options()
  toset <- !(names(teal_default_options) %in% names(op))
  if (any(toset)) options(teal_default_options[toset])

  # Set up the teal logger instance
  teal.logger::register_logger("teal.slice")
  teal.logger::register_handlers("teal.slice")

  invisible()
}

### GLOBAL VARIABLES ###

.filterable_class <- c("logical", "integer", "numeric", "factor", "character", "Date", "POSIXct", "POSIXlt")


### END GLOBAL VARIABLES ###


### ENSURE CHECK PASSES

# This function is necessary for check to properly process code dependencies within R6 classes.
# If `package` is listed in `Imports` in `DESCRIPTION`,
# (1) check goes through `NAMESPACE` looking for any `importFrom(package,<foo>)` statements
# or an `import(package)` statement. If none are found,
# (2) check looks for `package::*` calls in the code. If none are found again,
# (3) check throws a NOTE;
# #  Namespaces in Imports field not imported from:
# #    'package'
# #  All declared Imports should be used.
# This note is banned by our CI.
# When package::* statements are made within an R6 class, they are not registered.
# This function provides single references to the imported namespaces for check to notice.
.rectify_dependencies_check <- function() {
  dplyr::filter
  grDevices::rgb
  htmltools::tagInsertChildren
  lifecycle::badge
  logger::log_debug
  plotly::plot_ly
  shinycssloaders::withSpinner
  shinyWidgets::pickerOptions
  teal.data::datanames
  teal.widgets::optionalSelectInput
}


### END ENSURE CHECK PASSES

# FilterStateExpr ------

#' @name FilterStateExpr
#' @docType class
#'
#' @title `FilterStateExpr` `R6` class
#'
#' @description Sister class to `FilterState` that handles arbitrary filter expressions.
#'
#' @details
#' Creates a filter state around a predefined condition call (logical predicate).
#' The condition call is independent of the data
#' and the filter card allows no interaction (the filter is always fixed).
#'
#' @examples
#' # use non-exported function from teal.slice
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
#' FilterStateExpr <- getFromNamespace("FilterStateExpr", "teal.slice")
#'
#' filter_state <- FilterStateExpr$new(
#'   slice = teal_slice(
#'     dataname = "x",
#'     id = "FA",
#'     title = "Adult females",
#'     expr = "sex == 'F' & age >= 18"
#'   )
#' )
#' filter_state$get_call()
#'
#' # working filter in an app
#' library(shiny)
#' library(shinyjs)
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   column(4, tags$div(
#'     tags$h4("ChoicesFilterState"),
#'     filter_state$ui("fs")
#'   )),
#'   column(8, tags$div(
#'     tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_choices"), tags$br(),
#'     tags$h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_choices"), tags$br(),
#'     tags$h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_choices"), tags$br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   filter_state$server("fs")
#'   output$condition_choices <- renderPrint(filter_state$get_call())
#'   output$formatted_choices <- renderText(filter_state$format())
#'   output$unformatted_choices <- renderPrint(filter_state$get_state())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
FilterStateExpr <- R6::R6Class( # nolint
  classname = "FilterStateExpr",
  # public methods ----
  public = list(
    #' @description
    #' Initialize a `FilterStateExpr` object.
    #' @param slice (`teal_slice_expr`)
    #' @return Object of class `FilterStateExpr`, invisibly.
    #'
    initialize = function(slice) {
      checkmate::assert_class(slice, "teal_slice_expr")
      private$teal_slice <- slice
      invisible(self)
    },

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

    #' @description
    #' Prints this `FilterStateExpr` object.
    #' @param ... arguments passed to the `format` method
    #' @return `NULL`, invisibly.
    #'
    print = function(...) {
      cat(isolate(self$format(...)))
    },

    #' @description
    #' Returns a complete description of this filter state.
    #'
    #' @return A `teal_slice` object.
    #'
    get_state = function() {
      private$teal_slice
    },

    #' @description
    #' Does nothing. Exists for compatibility.
    #'
    #' @param state (`teal_slice`)
    #'
    #' @return `self`, invisibly.
    #'
    set_state = function(state) {
      checkmate::assert_class(state, "teal_slice_expr")
      invisible(self)
    },

    #' @description
    #' Get reproducible call.
    #'
    #' @param dataname (`ignored`) for a consistency with `FilterState`
    #'
    #' Returns reproducible condition call for current selection relevant
    #' for selected variable type.
    #' Method is using internal reactive values which makes it reactive
    #' and must be executed in reactive or isolated context.
    #'
    #' @return `call` or `NULL`
    #'
    get_call = function(dataname) {
      isolate(str2lang(private$teal_slice$expr))
    },

    #' @description
    #' Destroy inputs and observers stored in `private$session_bindings`.
    #'
    #' @return `NULL`, invisibly.
    #'
    finalize = function() {
      .finalize_session_bindings(self, private)
      invisible(NULL)
    },

    # public shiny modules ----

    #' @description
    #' `shiny` module server.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @param remove_callback (`function`)
    #'   callback to handle removal of this `FilterState` object from `state_list`
    #'
    #' @return Reactive expression signaling that the remove button has been clicked.
    #'
    server = function(id, remove_callback) {
      moduleServer(
        id = id,
        function(input, output, session) {
          private$server_summary("summary")

          private$session_bindings[[session$ns("remove")]] <- 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 = input$remove, # when remove button is clicked in the FilterState ui
            handlerExpr = remove_callback()
          )

          private$session_bindings[[session$ns("inputs")]] <- list(
            destroy = function() {
              logger::log_debug("Destroying FilterState inputs and observers; id: { private$get_id() }")
              lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
            }
          )

          NULL
        }
      )
    },

    #' @description
    #' `shiny` module UI.
    #'  The UI for this class contains simple message stating that it is not supported.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param parent_id (`character(1)`)
    #'   id of the `FilterStates` card container.
    ui = function(id, parent_id = "cards") {
      ns <- NS(id)
      isolate({
        tags$div(
          id = id,
          class = "panel filter-card",
          include_js_files("count-bar-labels.js"),
          tags$div(
            class = "filter-card-header",
            tags$div(
              class = "filter-card-title",
              if (private$is_anchored()) {
                icon("anchor-lock", class = "filter-card-icon")
              } else {
                icon("lock", class = "filter-card-icon")
              },
              tags$div(class = "filter-card-varname", tags$strong(private$teal_slice$id)),
              tags$div(class = "filter-card-varlabel", private$teal_slice$title),
              tags$div(
                class = "filter-card-controls",
                if (isFALSE(private$is_anchored())) {
                  actionLink(
                    inputId = ns("remove"),
                    label = icon("circle-xmark", lib = "font-awesome"),
                    title = "Remove filter",
                    class = "filter-card-remove"
                  )
                }
              )
            ),
            tags$div(
              class = "filter-card-summary",
              private$ui_summary(ns("summary"))
            )
          )
        )
      })
    }
  ),

  # private members ----

  private = list(
    session_bindings = list(), # stores observers and inputs to destroy afterwards
    teal_slice = NULL, # stores reactiveValues

    # @description
    # Get id of the teal_slice.
    # @return `character(1)`
    get_id = function() {
      isolate(private$teal_slice$id)
    },

    # Check whether this filter is anchored (cannot be removed).
    # @return `logical(1)`
    is_anchored = function() {
      isolate(isTRUE(private$teal_slice$anchored))
    },

    # @description
    # Server module to display filter summary
    # @param id `shiny` id parameter
    ui_summary = function(id) {
      ns <- NS(id)
      uiOutput(ns("summary"), class = "filter-card-summary")
    },

    # @description
    # UI module to display filter summary
    # @param shiny `id` parameter passed to moduleServer
    #  renders text describing current state
    server_summary = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          output$summary <- renderUI(private$content_summary())
        }
      )
    },
    content_summary = function() {
      isolate(private$teal_slice$expr)
    }
  )
)

# SEFilterStates ------

#' @name SEFilterStates
#' @docType class
#' @title `FilterStates` subclass for `SummarizedExperiment`s
#' @description Handles filter states in a `SummaryExperiment`.
#' @keywords internal
#'
SEFilterStates <- R6::R6Class( # nolint
  classname = "SEFilterStates",
  inherit = FilterStates,

  # public methods ----
  public = list(
    #' @description
    #' Initialize `SEFilterStates` object.
    #'
    #' @param data (`SummarizedExperiment`)
    #'   the `R` object which `subset` function is applied on.
    #' @param data_reactive (`function(sid)`)
    #'   should return a `SummarizedExperiment` 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 data used in the expression
    #'   specified to the function argument attached to this `FilterStates`.
    #' @param datalabel (`character(1)`) optional
    #'   text label. Should be the name of experiment.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL) {
      if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
        stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
      }
      checkmate::assert_function(data_reactive, args = "sid")
      checkmate::assert_class(data, "SummarizedExperiment")
      super$initialize(data, data_reactive, dataname, datalabel)
      if (!is.null(datalabel)) {
        private$dataname_prefixed <- sprintf(
          "%s[['%s']]", private$dataname_prefixed, datalabel
        )
      }
    },

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #'    `teal_slice` objects should contain the field `arg %in% c("subset", "select")`
    #'
    #' @return `NULL`, invisibly.
    #'
    set_filter_state = function(state) {
      isolate({
        logger::log_debug("SEFilterState$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(x) {
          checkmate::assert_choice(x$arg, choices = c("subset", "select"), null.ok = TRUE, .var.name = "teal_slice$arg")
        })
        count_type <- attr(state, "count_type")
        if (length(count_type)) {
          private$count_type <- count_type
        }

        subset_states <- Filter(function(x) x$arg == "subset", state)
        private$set_filter_state_impl(
          state = subset_states,
          data = SummarizedExperiment::rowData(private$data),
          data_reactive = function(sid = "") {
            data <- private$data_reactive()
            if (!is.null(data)) {
              SummarizedExperiment::rowData(data)
            }
          }
        )

        select_states <- Filter(function(x) x$arg == "select", state)
        private$set_filter_state_impl(
          state = select_states,
          data = SummarizedExperiment::colData(private$data),
          data_reactive = function(sid = "") {
            data <- private$data_reactive()
            if (!is.null(data)) {
              SummarizedExperiment::colData(data)
            }
          }
        )

        invisible(NULL)
      })
    },

    #' @description
    #' `shiny` UI module to add filter variable.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `shiny.tag`
    ui_add = function(id) {
      data <- private$data
      checkmate::assert_string(id)
      ns <- NS(id)
      row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
        tags$div("no sample variables available")
      } else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
        tags$div("no samples available")
      } else {
        teal.widgets::optionalSelectInput(
          ns("row_to_add"),
          choices = NULL,
          options = shinyWidgets::pickerOptions(
            liveSearch = TRUE,
            noneSelectedText = "Select gene variable"
          )
        )
      }

      col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
        tags$div("no sample variables available")
      } else if (nrow(SummarizedExperiment::colData(data)) == 0) {
        tags$div("no samples available")
      } else {
        teal.widgets::optionalSelectInput(
          ns("col_to_add"),
          choices = NULL,
          options = shinyWidgets::pickerOptions(
            liveSearch = TRUE,
            noneSelectedText = "Select sample variable"
          )
        )
      }

      tags$div(
        row_input,
        col_input
      )
    },

    #' @description
    #' `shiny` server module to add filter variable.
    #'
    #' Module controls available choices to select as a filter variable.
    #' Selected filter variable is being removed from available choices.
    #' Removed filter variable gets back to available choices.
    #' This module unlike other `FilterStates` classes manages two
    #' sets of filter variables - one for `colData` and another for
    #' `rowData`.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `NULL`
    srv_add = function(id) {
      data <- private$data
      data_reactive <- private$data_reactive
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("SEFilterState$srv_add initializing, dataname: { private$dataname }")

          row_data <- SummarizedExperiment::rowData(data)
          col_data <- SummarizedExperiment::colData(data)

          avail_row_data_choices <- reactive({
            slices_for_subset <- Filter(function(x) x$arg == "subset", self$get_filter_state())
            active_filter_row_vars <- unique(unlist(lapply(slices_for_subset, "[[", "varname")))

            choices <- setdiff(
              get_supported_filter_varnames(data = row_data),
              active_filter_row_vars
            )

            data_choices_labeled(
              data = row_data,
              choices = choices,
              varlabels = character(0),
              keys = NULL
            )
          })

          avail_col_data_choices <- reactive({
            slices_for_select <- Filter(function(x) x$arg == "select", self$get_filter_state())
            active_filter_col_vars <- unique(unlist(lapply(slices_for_select, "[[", "varname")))

            choices <- setdiff(
              get_supported_filter_varnames(data = col_data),
              active_filter_col_vars
            )

            data_choices_labeled(
              data = col_data,
              choices = choices,
              varlabels = character(0),
              keys = NULL
            )
          })

          private$session_bindings[[session$ns("avail_row_data_choices")]] <- observeEvent(
            avail_row_data_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_debug(
                "SEFilterStates$srv_add@1 updating available row data choices,",
                "dataname: { private$dataname }"
              )
              if (is.null(avail_row_data_choices())) {
                shinyjs::hide("row_to_add")
              } else {
                shinyjs::show("row_to_add")
              }
              teal.widgets::updateOptionalSelectInput(
                session,
                "row_to_add",
                choices = avail_row_data_choices()
              )
            }
          )

          private$session_bindings[[session$ns("avail_col_data_choices")]] <- observeEvent(
            avail_col_data_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_debug(
                "SEFilterStates$srv_add@2 updating available col data choices,",
                "dataname: { private$dataname }"
              )
              if (is.null(avail_col_data_choices())) {
                shinyjs::hide("col_to_add")
              } else {
                shinyjs::show("col_to_add")
              }
              teal.widgets::updateOptionalSelectInput(
                session,
                "col_to_add",
                choices = avail_col_data_choices()
              )
            }
          )

          private$session_bindings[[session$ns("col_to_add")]] <- observeEvent(
            eventExpr = input$col_to_add,
            handlerExpr = {
              logger::log_debug(
                "SEFilterStates$srv_add@3 adding FilterState of column { input$col_to_add }",
                " to col data, dataname: { private$dataname }"
              )
              varname <- input$col_to_add
              self$set_filter_state(teal_slices(
                teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select")
              ))
            }
          )


          private$session_bindings[[session$ns("row_to_add")]] <- observeEvent(
            eventExpr = input$row_to_add,
            handlerExpr = {
              logger::log_debug(
                "SEFilterStates$srv_add@4 adding FilterState of variable { input$row_to_add }",
                " to row data, dataname: { private$dataname }"
              )
              varname <- input$row_to_add
              self$set_filter_state(teal_slices(
                teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset")
              ))
            }
          )

          # Extra observer that clears all input values in session
          private$session_bindings[[session$ns("inputs")]] <- list(
            destroy = function() {
              lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
            }
          )

          NULL
        }
      )
    }
  )
)

#' Progress bars with labels
#'
#' `shiny` element displaying a series of progress bars and observation counts.
#'
#' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input).
#' @param choices (`vector`) Available values. Used to determine label text.
#' @param countsmax (`numeric`) Maximum counts of each element. Must be the same length `choices`.
#' @param countsnow (`numeric`) Current counts of each element. Must be the same length `choices`.
#' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`.
#'
#' @return List of `shiny.tag`s.
#'
#' Creates a number of progress bar elements, one for each value of `choices`.
#' The widths of all progress bars add up to the full width of the container.
#' Each progress bar has a text label that contains the name of the value and the number of counts.
#'
#' If the filter panel is used with `count_type = "all"`, the progress bars will be filled
#' according to the number of counts remaining in the current selection and the label will show
#' both the current and the total number of counts.
#'
#' Each child element can have a unique `id` attribute to be used independently.
#'
#' @examples
#' # use non-exported function from teal.slice
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
#' countBars <- getFromNamespace("countBars", "teal.slice")
#' updateCountBars <- getFromNamespace("updateCountBars", "teal.slice")
#'
#' library(shiny)
#'
#' choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE)
#' counts <- table(choices)
#' labels <- countBars(
#'   inputId = "counts",
#'   choices = c("a", "b", "c"),
#'   countsmax = counts,
#'   countsnow = unname(counts)
#' )
#'
#' ui <- fluidPage(
#'   tags$div(
#'     class = "choices_state",
#'     include_js_files("count-bar-labels.js"),
#'     include_css_files(pattern = "filter-panel"),
#'     checkboxGroupInput(
#'       inputId = "choices",
#'       selected = levels(choices),
#'       choiceNames = labels,
#'       choiceValues = levels(choices),
#'       label = NULL
#'     )
#'   )
#' )
#' server <- function(input, output, session) {
#'   observeEvent(input$choices, {
#'     new_counts <- counts
#'     new_counts[!names(new_counts) %in% input$choices] <- 0
#'     updateCountBars(
#'       inputId = "counts",
#'       choices = levels(choices),
#'       countsmax = counts,
#'       countsnow = unname(new_counts)
#'     )
#'   })
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
countBars <- function(inputId, choices, countsmax, countsnow = NULL) { # nolint
  checkmate::assert_string(inputId)
  checkmate::assert_vector(choices)
  checkmate::assert_numeric(countsmax, len = length(choices))
  checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)
  if (!is.null(countsnow)) {
    checkmate::assert_true(all(countsnow <= countsmax))
  }

  ns <- NS(inputId)

  mapply(
    countBar,
    inputId = ns(seq_along(choices)),
    label = as.character(choices),
    countmax = countsmax,
    countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
    MoreArgs = list(
      counttotal = sum(countsmax)
    ),
    SIMPLIFY = FALSE, USE.NAMES = FALSE
  )
}

#' Progress bar with label
#'
#' `shiny` element displaying a progress bar and observation count.
#'
#' A progress bar is created to visualize the number of counts in a variable, with filling and a text label.
#' - progress bar width is derived as a fraction of the container width: `style = "width: <countmax> / <counttotal>%"`,
#' - progress bar is filled up to the fraction `<countnow> / <countmax>`,
#' - text label is obtained by `<label> (<countnow> / <countmax>)`.
#'
#' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input).
#' @param label (`character(1)`) Text to display followed by counts.
#' @param countmax (`numeric(1)`) Maximum count for a single element.
#' @param countnow (`numeric(1)`) Current count for a single element.
#' @param counttotal (`numeric(1)`) Sum total of maximum counts of all elements, see `Details`.
#' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`.
#'
#' @return `shiny.tag` object with a progress bar and a label.
#'
#' @keywords internal
#'
countBar <- function(inputId, label, countmax, countnow = NULL, counttotal = countmax) { # nolint
  checkmate::assert_string(inputId)
  checkmate::assert_string(label)
  checkmate::assert_number(countmax)
  checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax)
  checkmate::assert_number(counttotal, lower = countmax)

  label <- make_count_text(label, countmax = countmax, countnow = countnow)
  ns <- NS(inputId)
  if (is.null(countnow)) countnow <- 0
  tags$div(
    class = "progress state-count-container",
    # * .9 to not exceed width of the parent html element
    tags$div(
      id = ns("count_bar_filtered"),
      class = "progress-bar state-count-bar-filtered",
      style = sprintf("width: %s%%", countnow / counttotal * 100),
      role = "progressbar",
      label
    ),
    tags$div(
      id = ns("count_bar_unfiltered"),
      class = "progress-bar state-count-bar-unfiltered",
      style = sprintf("width: %s%%", (countmax - countnow) / counttotal * 100),
      role = "progressbar"
    )
  )
}

#' @rdname countBars
updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, countsmax, countsnow = NULL) { # nolint
  checkmate::assert_string(inputId)
  checkmate::assert_vector(choices)
  checkmate::assert_numeric(countsmax, len = length(choices))
  checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)

  ns <- NS(inputId)
  mapply(
    updateCountBar,
    inputId = ns(seq_along(choices)),
    label = choices,
    countmax = countsmax,
    countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
    MoreArgs = list(
      counttotal = sum(countsmax)
    )
  )
  invisible(NULL)
}

#' @rdname countBar
updateCountBar <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow = NULL, counttotal) { # nolint
  checkmate::assert_string(inputId)
  checkmate::assert_string(label)
  checkmate::assert_number(countmax)
  checkmate::assert_number(countnow, null.ok = TRUE)
  checkmate::assert_number(counttotal)

  label <- make_count_text(label, countmax = countmax, countnow = countnow)
  if (is.null(countnow)) countnow <- countmax
  session$sendCustomMessage(
    type = "updateCountBar",
    message = list(
      id = session$ns(inputId),
      label = label,
      countmax = countmax,
      countnow = countnow,
      counttotal = counttotal
    )
  )

  invisible(NULL)
}

#' @rdname countBar
updateCountText <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow) { # nolint
  checkmate::assert_string(inputId)
  checkmate::assert_string(label)
  checkmate::assert_number(countmax)
  checkmate::assert_number(countnow, null.ok = TRUE)
  label <- make_count_text(label, countmax = countmax, countnow = countnow)
  session$sendCustomMessage(
    type = "updateCountText",
    message = list(
      id = session$ns(inputId),
      label = label
    )
  )
}

#' Build count text
#'
#' Returns a text label describing filtered counts. The text is composed in the following way:
#' - when `countnow` is not `NULL`: `<label> (<countnow>/<countmax>)`
#' - when `countnow` is `NULL`: `<label> (<countmax>)`
#'
#' @param label (`character(1)`) Text displayed before counts.
#' @param countnow (`numeric(1)`) Number of filtered counts.
#' @param countmax (`numeric(1)`) Number of unfiltered counts.
#'
#' @return A character string.
#'
#' @keywords internal
#'
make_count_text <- function(label, countmax, countnow = NULL) {
  checkmate::assert_string(label)
  checkmate::assert_number(countmax)
  checkmate::assert_number(countnow, null.ok = TRUE)
  sprintf(
    "%s (%s%s)",
    label,
    if (is.null(countnow)) "" else sprintf("%s/", countnow),
    countmax
  )
}


#' Adjust counts to match choices
#'
#' @param choices (`character`) Choices to match.
#' @param counts (`named numeric`) Counts to adjust.
#' @keywords internal
pair_counts <- function(choices, counts) {
  checkmate::assert_numeric(counts)
  counts <- counts[match(choices, names(counts))]
  counts[is.na(counts)] <- 0
  names(counts) <- choices
  counts
}

#' Include `JS` files from `/inst/js/` package directory to application header
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`. Therefore, we redefine this method in each package
#' as needed. Thus, we do not export this method.
#'
#' @param pattern (`character`) pattern of files to be included, passed to `system.file`
#'
#' @return HTML code that includes `JS` files
#' @keywords internal
include_js_files <- function(pattern) {
  checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE)
  js_files <- list.files(
    system.file("js", package = "teal.slice", mustWork = TRUE),
    pattern = pattern,
    full.names = TRUE
  )
  singleton(lapply(js_files, includeScript))
}

#' Build concatenating call
#'
#' This function takes a vector of values and returns a `c` call. If the vector
#' has only one element, the element is returned directly.
#'
#' @param choices A vector of values.
#'
#' @return A `c` call.
#'
#' @examples
#' # use non-exported function from teal.slice
#' make_c_call <- getFromNamespace("make_c_call", "teal.slice")
#' make_c_call(1:3)
#' make_c_call(1)
#'
#' @keywords internal
make_c_call <- function(choices) {
  if (length(choices) > 1) {
    do.call("call", append(list("c"), choices))
  } else {
    choices
  }
}

#' Destroys inputs and observers stored in `private$session_bindings`
#'
#' @description
#' Call a `destroy` method to remove `observer` and `input` from obsolete session which happens
#' when `filter_panel_srv` is called again in new `FilteredData` object.
#' Inputs are not stored directly in a field as they don't have `destroy` method. Instead, we
#' store callback `destroy` function for inputs which removes bindings from a `session`.
#' @param self,private slots of a `R6` class
#' @return `NULL` invisibly
#' @keywords internal
.finalize_session_bindings <- function(self, private) {
  # Only finalize shiny session binding when there is an active session
  if (
    !is.null(getDefaultReactiveDomain()) &&
      !getDefaultReactiveDomain()$isEnded()
  ) {
    lapply(private$session_bindings, function(x) x$destroy())
  }
  invisible(NULL)
}



#' Encodes ids to be used in JavaScript and Shiny
#'
#' @description
#' Replaces non-ASCII characters into a format that can be used in HTML,
#' JavaScript and Shiny.
#'
#' When the id has a character that is not allowed, it is replaced with `"_"`
#' and a 4 character hash of the original id is added to the start of the
#' resulting id.
#'
#'
#' @param id (`character(1)`) The id string.
#'
#' @return Sanitized string that removes special characters and spaces.
#'
#' @keywords internal
sanitize_id <- function(id) {
  pattern_escape <- "[^0-9A-Za-z_]"

  id_new <- gsub(pattern_escape, "_", id, perl = TRUE)
  hashes <- vapply(id[id != id_new], rlang::hash, character(1), USE.NAMES = FALSE)

  id[id != id_new] <- paste0("h", substr(hashes, 1, 4), "_", id_new[id != id_new])
  id
}

#' `NS` wrapper to sanitize ids for shiny
#'
#' Special characters and spaces are not allowed in shiny ids (in JS)
#'
#' @noRd
NS <- function(namespace, id = NULL) { # nolint: object_name.
  if (!missing(id)) {
    return(shiny::NS(namespace, sanitize_id(id)))
  }

  function(id) {
    shiny::NS(namespace, sanitize_id(id))
  }
}

#' `moduleServer` wrapper to sanitize ids for shiny
#'
#' Special characters and spaces are not allowed in shiny ids (in JS)
#'
#' @noRd
moduleServer <- function(id, module, session = getDefaultReactiveDomain()) { # nolint: object_name.
  id <- sanitize_id(id)
  shiny::moduleServer(id, module, session)
}

#' Get classes of selected columns from dataset
#'
#' @param data (`data.frame` or `DataFrame` or `matrix`) Object in which to determine variable types.
#' @param columns (`character`) Vector of columns in `data` for which to get types.
#'   Set to `NULL` to get types of all columns.
#'
#' @return Character vector of classes of `columns` from provided `data`.
#'
#' @examples
#' # use non-exported function from teal.slice
#' variable_types <- getFromNamespace("variable_types", "teal.slice")
#'
#' variable_types(
#'   data.frame(
#'     x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
#'     stringsAsFactors = FALSE
#'   ),
#'   "x"
#' )
#'
#' variable_types(
#'   data.frame(
#'     x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
#'     stringsAsFactors = FALSE
#'   ),
#'   c("x", "z")
#' )
#'
#' variable_types(
#'   data.frame(
#'     x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
#'     stringsAsFactors = FALSE
#'   )
#' )
#'
#' @keywords internal
#'
variable_types <- function(data, columns = NULL) {
  checkmate::assert_multi_class(data, c("data.frame", "DataFrame", "matrix"))
  checkmate::assert_character(columns, any.missing = FALSE, null.ok = TRUE)
  checkmate::assert_subset(columns, colnames(data))

  if (is.matrix(data)) {
    type <- typeof(data)
    if (type == "double") type <- "numeric"
    types <-
      if (is.null(columns)) {
        stats::setNames(rep_len(type, ncol(data)), nm = colnames(data))
      } else {
        stats::setNames(rep_len(type, length(columns)), nm = columns)
      }
  } else {
    types <- vapply(data, function(x) class(x)[1L], character(1L))
    if (!is.null(columns)) types <- types[columns]
    # alternative after R 4.4.0: `types <- types[columns %||% TRUE]`
  }
  types
}

# MAEFilteredDataset ------

#' @name MAEFilteredDataset
#' @docType class
#' @title `MAEFilteredDataset` `R6` class
#'
#' @examplesIf requireNamespace("MultiAssayExperiment")
#' # use non-exported function from teal.slice
#' MAEFilteredDataset <- getFromNamespace("MAEFilteredDataset", "teal.slice")
#'
#' data(miniACC, package = "MultiAssayExperiment")
#' dataset <- MAEFilteredDataset$new(miniACC, "MAE")
#' fs <- teal_slices(
#'   teal_slice(
#'     dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE
#'   ),
#'   teal_slice(
#'     dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE
#'   ),
#'   teal_slice(
#'     dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE
#'   ),
#'   teal_slice(
#'     dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE
#'   )
#' )
#' dataset$set_filter_state(state = fs)
#'
#' library(shiny)
#' isolate(dataset$get_filter_state())
#'
#' @keywords internal
#'
MAEFilteredDataset <- R6::R6Class( # nolint
  classname = "MAEFilteredDataset",
  inherit = FilteredDataset,

  # public methods ----
  public = list(
    #' @description
    #' Initialize `MAEFilteredDataset` object.
    #'
    #' @param dataset (`MulitiAssayExperiment`)
    #'  single `MulitiAssayExperiment` for which filters are rendered.
    #' @param dataname (`character(1)`)
    #'  syntactically valid name given to the dataset.
    #' @param keys (`character`) optional
    #'   vector of primary key column names.
    #' @param label (`character(1)`)
    #'   label to describe the dataset.
    #'
    #' @return Object of class `MAEFilteredDataset`, invisibly.
    #'
    initialize = function(dataset, dataname, keys = character(0), label = character(0)) {
      if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
        stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
      }
      checkmate::assert_class(dataset, "MultiAssayExperiment")
      super$initialize(dataset, dataname, keys, label)
      experiment_names <- names(dataset)

      # subsetting by subjects means subsetting by colData(MAE)
      private$add_filter_states(
        filter_states = init_filter_states(
          data = dataset,
          data_reactive = private$data_filtered_fun,
          dataname = dataname,
          datalabel = "subjects",
          keys = self$get_keys()
        ),
        id = "subjects"
      )
      # elements of the list (experiments) are unknown
      # dispatch needed because we can't hardcode methods otherwise:
      #  if (matrix) else if (SummarizedExperiment) else if ...
      lapply(
        experiment_names,
        function(experiment_name) {
          data_reactive <- function(sid = "") private$data_filtered_fun(sid)[[experiment_name]]
          private$add_filter_states(
            filter_states = init_filter_states(
              data = dataset[[experiment_name]],
              data_reactive = data_reactive,
              dataname = dataname,
              datalabel = experiment_name
            ),
            id = experiment_name
          )
        }
      )
    },

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #' @return `NULL`, invisibly.
    #'
    set_filter_state = function(state) {
      isolate({
        logger::log_debug("FilteredDatasetMAE$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")
        })

        # set state on subjects
        subject_state <- Filter(function(x) is.null(x$experiment), state)
        private$get_filter_states()[["subjects"]]$set_filter_state(subject_state)

        # set state on experiments
        # determine target experiments (defined in teal_slices)
        experiments <- unique(unlist(lapply(state, "[[", "experiment")))
        available_experiments <- setdiff(names(private$get_filter_states()), "subjects")
        excluded_filters <- setdiff(experiments, available_experiments)
        if (length(excluded_filters)) {
          stop(sprintf(
            "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",
            private$dataname,
            toString(excluded_filters),
            toString(available_experiments)
          ))
        }

        # set states on state_lists with corresponding experiments
        lapply(available_experiments, function(experiment) {
          slices <- Filter(function(x) identical(x$experiment, experiment), state)
          private$get_filter_states()[[experiment]]$set_filter_state(slices)
        })

        invisible(NULL)
      })
    },

    #' @description
    #' Remove one or more `FilterState` of a `MAEFilteredDataset`.
    #'
    #' @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({
        logger::log_debug("FilteredDatasetMAE$remove_filter_state removing filter(s), dataname: { private$dataname }")
        # remove state on subjects
        subject_state <- Filter(function(x) is.null(x$experiment), state)
        private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state)

        # remove state on experiments
        # determine target experiments (defined in teal_slices)
        experiments <- unique(unlist(lapply(state, "[[", "experiment")))
        available_experiments <- setdiff(names(private$get_filter_states()), "subjects")
        excluded_filters <- setdiff(experiments, available_experiments)
        if (length(excluded_filters)) {
          stop(sprintf(
            "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",
            private$dataname,
            toString(excluded_filters),
            toString(available_experiments)
          ))
        }
        # remove states on state_lists with corresponding experiments
        lapply(experiments, function(experiment) {
          slices <- Filter(function(x) identical(x$experiment, experiment), state)
          private$get_filter_states()[[experiment]]$remove_filter_state(slices)
        })
      })

      invisible(NULL)
    },

    #' @description
    #' UI module to add filter variable for this dataset.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `shiny.tag`
    #'
    ui_add = function(id) {
      ns <- NS(id)
      data <- self$get_dataset()
      experiment_names <- names(data)

      tags$div(
        tags$label("Add", tags$code(self$get_dataname()), "filter"),
        tags$br(),
        HTML("&#9658;"),
        tags$label("Add subjects filter"),
        private$get_filter_states()[["subjects"]]$ui_add(id = ns("subjects")),
        tagList(
          lapply(
            experiment_names,
            function(experiment_name) {
              tagList(
                HTML("&#9658;"),
                tags$label("Add", tags$code(experiment_name), "filter"),
                private$get_filter_states()[[experiment_name]]$ui_add(id = ns(experiment_name))
              )
            }
          )
        )
      )
    },

    #' @description
    #' Creates row for filter overview in the form of \cr
    #' `dataname -- observations (remaining/total) -- subjects (remaining/total)` - MAE
    #' @return A `data.frame`.
    get_filter_overview = function() {
      data <- self$get_dataset()
      data_filtered <- self$get_dataset(TRUE)
      experiment_names <- names(data)

      mae_info <- data.frame(
        dataname = private$dataname,
        subjects = nrow(SummarizedExperiment::colData(data)),
        subjects_filtered = nrow(SummarizedExperiment::colData(data_filtered()))
      )

      experiment_obs_info <- do.call("rbind", lapply(
        experiment_names,
        function(experiment_name) {
          data.frame(
            dataname = sprintf("- %s", experiment_name),
            obs = nrow(data[[experiment_name]]),
            obs_filtered = nrow(data_filtered()[[experiment_name]])
          )
        }
      ))

      get_experiment_keys <- function(mae, experiment) {
        sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment))
        length(unique(sample_subset$primary))
      }

      experiment_subjects_info <- do.call("rbind", lapply(
        experiment_names,
        function(experiment_name) {
          data.frame(
            subjects = get_experiment_keys(data, data[[experiment_name]]),
            subjects_filtered = get_experiment_keys(data_filtered(), data_filtered()[[experiment_name]])
          )
        }
      ))

      experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)
      dplyr::bind_rows(mae_info, experiment_info)
    }
  )
)

# ChoicesFilterState ------

#' @name ChoicesFilterState
#' @docType class
#'
#' @title `FilterState` object for categorical data
#'
#' @description Manages choosing elements from a set.
#'
#' @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")
#' ChoicesFilterState <- getFromNamespace("ChoicesFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- ChoicesFilterState$new(
#'   x = c(LETTERS, NA),
#'   slice = teal_slice(varname = "var", dataname = "data")
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#'   teal_slice(
#'     dataname = "data",
#'     varname = "var",
#'     selected = "A",
#'     keep_na = TRUE
#'   )
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA)
#' attr(data_choices, "label") <- "lowercase letters"
#' fs <- ChoicesFilterState$new(
#'   x = data_choices,
#'   slice = teal_slice(
#'     dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE
#'   )
#' )
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   column(4, tags$div(
#'     tags$h4("ChoicesFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_choices"), tags$br(),
#'     tags$h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_choices"), tags$br(),
#'     tags$h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_choices"), tags$br()
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Programmatic filter control"),
#'     actionButton("button1_choices", "set drop NA", width = "100%"), tags$br(),
#'     actionButton("button2_choices", "set keep NA", width = "100%"), tags$br(),
#'     actionButton("button3_choices", "set selection: a, b", width = "100%"), tags$br(),
#'     actionButton("button4_choices", "deselect all", width = "100%"), tags$br(),
#'     actionButton("button0_choices", "set initial state", width = "100%"), tags$br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_choices <- renderPrint(fs$get_call())
#'   output$formatted_choices <- renderText(fs$format())
#'   output$unformatted_choices <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", keep_na = FALSE)
#'     )
#'   )
#'   observeEvent(
#'     input$button2_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", keep_na = TRUE)
#'     )
#'   )
#'   observeEvent(
#'     input$button3_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = c("a", "b"))
#'     )
#'   )
#'   observeEvent(
#'     input$button4_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE)
#'     )
#'   )
#'   observeEvent(
#'     input$button0_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
ChoicesFilterState <- R6::R6Class( # nolint
  "ChoicesFilterState",
  inherit = FilterState,

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `FilterState` object.
    #'
    #' @param x (`character`)
    #'   variable to be filtered.
    #' @param x_reactive (`reactive`)
    #'   returning vector of the same type as `x`. Is used to update
    #'   counts following the change in values of the filtered dataset.
    #'   If it is set to `reactive(NULL)` then counts based on filtered
    #'   dataset are not shown.
    #' @param slice (`teal_slice`)
    #'   specification of this filter state.
    #'   `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
    #'   `get_state` returns `teal_slice` object which can be reused in other places.
    #'   Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
    #'   changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
    #' @param extract_type (`character`)
    #'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
    #' - `character(0)` (default) `varname` in the condition call will not be prefixed
    #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
    #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
    #'
    #' @return Object of class `ChoicesFilterState`, invisibly.
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          slice,
                          extract_type = character(0)) {
      isolate({
        checkmate::assert(
          is.character(x),
          is.factor(x),
          length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
          combine = "or"
        )
        if (is.factor(x)) {
          x <- droplevels(x)
        }
        super$initialize(
          x = x,
          x_reactive = x_reactive,
          slice = slice,
          extract_type = extract_type
        )
        private$set_choices(slice$choices)
        if (is.null(slice$selected) && slice$multiple) {
          slice$selected <- private$get_choices()
        } else if (is.null(slice$selected)) {
          slice$selected <- private$get_choices()[1]
        } else if (length(slice$selected) > 1 && !slice$multiple) {
          warning(
            "ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ",
            "Only the first value will be used."
          )
          slice$selected <- slice$selected[1]
        }
        private$set_selected(slice$selected)
        if (inherits(x, "POSIXt")) {
          private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))
        }
      })
      invisible(self)
    },

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For this class returned call looks like
    #' `<varname> %in% c(<values selected>)` with optional `is.na(<varname>)`.
    #' @param dataname (`character(1)`) name of data set; defaults to `private$get_dataname()`
    #' @return `call` or `NULL`
    #'
    get_call = function(dataname) {
      if (isFALSE(private$is_any_filtered())) {
        return(NULL)
      }
      if (missing(dataname)) dataname <- private$get_dataname()
      varname <- private$get_varname_prefixed(dataname)
      choices <- private$get_choices()
      selected <- private$get_selected()
      fun_compare <- if (length(selected) == 1L) "==" else "%in%"
      filter_call <- if (length(selected) == 0) {
        call("!", call(fun_compare, varname, make_c_call(as.character(choices))))
      } else {
        if (setequal(selected, choices) && !private$is_choice_limited) {
          NULL
        } else if (inherits(private$x, "Date")) {
          call(fun_compare, varname, call("as.Date", make_c_call(as.character(selected))))
        } else if (inherits(private$x, c("POSIXct", "POSIXlt"))) {
          class <- class(private$x)[1L]
          date_fun <- as.name(
            switch(class,
              "POSIXct" = "as.POSIXct",
              "POSIXlt" = "as.POSIXlt"
            )
          )
          call(
            fun_compare,
            varname,
            as.call(list(date_fun, make_c_call(as.character(selected)), tz = private$tzone))
          )
        } else if (is.numeric(private$x)) {
          call(fun_compare, varname, make_c_call(as.numeric(selected)))
        } else {
          # This handles numerics, characters, and factors.
          call(fun_compare, varname, make_c_call(selected))
        }
      }
      private$add_keep_na_call(filter_call, varname)
    }
  ),

  # private members ----
  private = list(
    x = NULL,
    choices_counts = integer(0),
    tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call

    # private methods ----

    # @description
    # Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices
    #  are limited by default from the start.
    set_choices = function(choices) {
      named_counts <- .table(private$x)
      possible_choices <- names(named_counts)
      if (is.null(choices)) {
        choices <- possible_choices
      } else {
        choices <- as.character(choices)
        choices_adjusted <- choices[choices %in% possible_choices]
        if (length(setdiff(choices, choices_adjusted)) > 0L) {
          warning(
            sprintf(
              "Some choices not found in data. Adjusting. Filter id: %s.",
              private$get_id()
            )
          )
          choices <- choices_adjusted
        }
        if (length(choices) == 0) {
          warning(
            sprintf(
              "None of the choices were found in data. Setting defaults. Filter id: %s.",
              private$get_id()
            )
          )
          choices <- possible_choices
        }
      }
      private$set_choices_counts(
        pair_counts(choices, named_counts)
      )
      private$set_is_choice_limited(possible_choices, choices)
      private$teal_slice$choices <- choices
      invisible(NULL)
    },
    # @description
    # Check whether the initial choices filter out some values of x and set the flag in case.
    set_is_choice_limited = function(x, choices) {
      xl <- x[!is.na(x)]
      private$is_choice_limited <- length(setdiff(xl, choices)) > 0L
      invisible(NULL)
    },
    # @description
    # Sets choices_counts private field.
    set_choices_counts = function(choices_counts) {
      private$choices_counts <- choices_counts
      invisible(NULL)
    },
    # @description
    # Checks whether the input should be rendered as a checkboxgroup/radiobutton or a drop-down.
    is_checkboxgroup = function() {
      length(private$get_choices()) <= getOption("teal.threshold_slider_vs_checkboxgroup")
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.character(values)
          if (anyNA(values)) stop()
        },
        error = function(e) stop("The vector of set values must contain values coercible to character.")
      )
      values
    },
    # If multiple forbidden but selected, restores previous selection with warning.
    check_length = function(values) {
      if (!private$is_multiple() && length(values) > 1) {
        warning(
          sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
          "Maintaining previous selection."
        )
        values <- isolate(private$get_selected())
      }
      values
    },
    remove_out_of_bounds_values = function(values) {
      in_choices_mask <- values %in% private$get_choices()
      if (length(values[!in_choices_mask]) > 0) {
        warning(paste(
          "Values:", toString(values[!in_choices_mask], width = 360),
          "are not in choices of column", private$get_varname(), "in dataset", private$get_dataname(), "."
        ))
      }
      values[in_choices_mask]
    },

    # shiny modules ----

    # @description
    # UI Module for `ChoicesFilterState`.
    # This UI element contains available choices selection and
    # checkbox whether to keep or not keep the `NA` values.
    # @param id (`character(1)`) `shiny` module instance id.
    ui_inputs = function(id) {
      ns <- NS(id)

      # we need to isolate UI to not retrigger renderUI
      isolate({
        countsmax <- private$choices_counts
        countsnow <- if (!is.null(private$x_reactive())) {
          pair_counts(
            private$get_choices(),
            .table(private$x_reactive())
          )
        }

        ui_input <- if (private$is_checkboxgroup()) {
          labels <- countBars(
            inputId = ns("labels"),
            choices = private$get_choices(),
            countsnow = countsnow,
            countsmax = countsmax
          )
          tags$div(
            class = "choices_state",
            if (private$is_multiple()) {
              checkboxGroupInput(
                inputId = ns("selection"),
                label = NULL,
                selected = private$get_selected(),
                choiceNames = labels,
                choiceValues = private$get_choices(),
                width = "100%"
              )
            } else {
              radioButtons(
                inputId = ns("selection"),
                label = NULL,
                selected = private$get_selected(),
                choiceNames = labels,
                choiceValues = private$get_choices(),
                width = "100%"
              )
            }
          )
        } else {
          labels <- mapply(
            FUN = make_count_text,
            label = private$get_choices(),
            countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,
            countmax = countsmax
          )

          teal.widgets::optionalSelectInput(
            inputId = ns("selection"),
            choices = stats::setNames(private$get_choices(), labels),
            selected = private$get_selected(),
            multiple = private$is_multiple(),
            options = shinyWidgets::pickerOptions(
              actionsBox = TRUE,
              liveSearch = (length(private$get_choices()) > 10),
              noneSelectedText = "Select a value"
            )
          )
        }
        tags$div(
          uiOutput(ns("trigger_visible")),
          ui_input,
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

    # @description
    # Server module
    # @param id (`character(1)`) `shiny` module instance id.
    # @return `NULL`.
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }")
          # 1. renderUI is used here as an observer which triggers only if output is visible
          #  and if the reactive changes - reactive triggers only if the output is visible.
          # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)
          non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))
          output$trigger_visible <- renderUI({
            logger::log_debug("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")

            countsnow <- if (!is.null(private$x_reactive())) {
              pair_counts(
                private$get_choices(),
                .table(non_missing_values())
              )
            }

            # update should be based on a change of counts only
            isolate({
              if (private$is_checkboxgroup()) {
                updateCountBars(
                  inputId = "labels",
                  choices = private$get_choices(),
                  countsmax = private$choices_counts,
                  countsnow = countsnow
                )
              } else {
                labels <- mapply(
                  FUN = make_count_text,
                  label = private$get_choices(),
                  countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,
                  countmax = private$choices_counts
                )
                teal.widgets::updateOptionalSelectInput(
                  session = session,
                  inputId = "selection",
                  choices = stats::setNames(private$get_choices(), labels),
                  selected = private$get_selected()
                )
              }
              NULL
            })
          })

          private$session_bindings[[session$ns("selection")]] <- if (private$is_checkboxgroup()) {
            observeEvent(
              ignoreNULL = FALSE,
              ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
              eventExpr = input$selection,
              handlerExpr = {
                logger::log_debug("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")

                selection <- if (is.null(input$selection) && private$is_multiple()) {
                  character(0)
                } else {
                  input$selection
                }

                private$set_selected(selection)
              }
            )
          } else {
            observeEvent(
              ignoreNULL = FALSE,
              ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
              eventExpr = input$selection_open, # observe click on a dropdown
              handlerExpr = {
                if (!isTRUE(input$selection_open)) { # only when the dropdown got closed
                  logger::log_debug("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")

                  selection <- if (is.null(input$selection) && private$is_multiple()) {
                    character(0)
                  } else if (isTRUE(length(input$selection) != 1) && !private$is_multiple()) {
                    # In optionalSelectInput user is able to select mutliple options. But if FilterState is not multiple
                    # we should prevent this selection to be processed further.
                    # This is why notification is thrown and dropdown is changed back to latest selected.
                    showNotification(paste(
                      "This filter exclusively supports single selection.",
                      "Any additional choices made will be disregarded."
                    ))
                    teal.widgets::updateOptionalSelectInput(
                      session, "selection",
                      selected = private$get_selected()
                    )
                    return(NULL)
                  } else {
                    input$selection
                  }
                  private$set_selected(selection)
                }
              }
            )
          }

          private$keep_na_srv("keep_na")

          # this observer is needed in the situation when teal_slice$selected has been
          # changed directly by the api - then it's needed to rerender UI element
          # to show relevant values
          private$session_bindings[[session$ns("selection_api")]] <- observeEvent(private$get_selected(), {
            # it's important to not retrigger when the input$selection is the same as reactive values
            # kept in the teal_slice$selected
            if (!setequal(input$selection, private$get_selected())) {
              logger::log_debug("ChoicesFilterState$server@1 state changed, id: { private$get_id() }")
              if (private$is_checkboxgroup()) {
                if (private$is_multiple()) {
                  updateCheckboxGroupInput(
                    inputId = "selection",
                    selected = private$get_selected()
                  )
                } else {
                  updateRadioButtons(
                    inputId = "selection",
                    selected = private$get_selected()
                  )
                }
              } else {
                teal.widgets::updateOptionalSelectInput(
                  session, "selection",
                  selected = private$get_selected()
                )
              }
            }
          })

          NULL
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("ChoicesFilterState$server_inputs_fixed initializing, id: { private$get_id() }")

          output$selection <- renderUI({
            countsnow <- if (!is.null(private$x_reactive())) {
              pair_counts(
                private$get_choices(),
                .table(private$x_reactive())
              )
            }
            countsmax <- private$choices_counts

            ind <- private$get_choices() %in% isolate(private$get_selected())
            countBars(
              inputId = session$ns("labels"),
              choices = isolate(private$get_selected()),
              countsnow = countsnow[ind],
              countsmax = countsmax[ind]
            )
          })

          NULL
        }
      )
    },

    # @description
    # UI module to display filter summary
    #  renders text describing number of selected levels
    #  and if NA are included also
    content_summary = function(id) {
      selected <- private$get_selected()
      selected_text <-
        if (length(selected) == 0L) {
          "no selection"
        } else {
          if (sum(nchar(selected)) <= 40L) {
            paste(selected, collapse = ", ")
          } else {
            paste(length(selected), "levels selected")
          }
        }
      tagList(
        tags$span(
          class = "filter-card-summary-value",
          selected_text
        ),
        tags$span(
          class = "filter-card-summary-controls",
          if (private$na_count > 0) {
            tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
          }
        )
      )
    }
  )
)

#' `table` handling `POSIXlt`
#'
#' @param x (`vector`) variable to get counts from.
#' @return vector of counts named by unique values of `x`.
#'
#' @keywords internal
.table <- function(x) {
  tbl <- table(
    if (is.factor(x)) {
      x
    } else {
      as.character(x)
    }
  )
  # tbl returns an array with dimnames instead of a simple vector
  # we need to convert it to a vector so the object is simpler to handle
  stats::setNames(
    as.vector(tbl),
    names(tbl)
  )
}

# DateFilterState ------

#' @name DateFilterState
#' @docType class
#'
#' @title `FilterState` object for `Date` data
#'
#' @description Manages choosing a range of `Date`s.
#'
#' @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")
#' DateFilterState <- getFromNamespace("DateFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- DateFilterState$new(
#'   x = c(Sys.Date() + seq(1:10), NA),
#'   slice = teal_slice(varname = "x", dataname = "data"),
#'   extract_type = character(0)
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#'   teal_slice(
#'     dataname = "data",
#'     varname = "x",
#'     selected = c(Sys.Date() + 3L, Sys.Date() + 8L),
#'     keep_na = TRUE
#'   )
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' dates <- c(Sys.Date() - 100, Sys.Date())
#' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA)
#' fs <- DateFilterState$new(
#'   x = data_date,
#'   slice = teal_slice(
#'     dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE
#'   )
#' )
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   column(4, tags$div(
#'     tags$h4("DateFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, tags$div(
#'     id = "outputs", # div id is needed for toggling the element
#'     tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_date"), tags$br(),
#'     tags$h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_date"), tags$br(),
#'     tags$h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_date"), tags$br()
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Programmatic filter control"),
#'     actionButton("button1_date", "set drop NA", width = "100%"), tags$br(),
#'     actionButton("button2_date", "set keep NA", width = "100%"), tags$br(),
#'     actionButton("button3_date", "set a range", width = "100%"), tags$br(),
#'     actionButton("button4_date", "set full range", width = "100%"), tags$br(),
#'     actionButton("button0_date", "set initial state", width = "100%"), tags$br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_date <- renderPrint(fs$get_call())
#'   output$formatted_date <- renderText(fs$format())
#'   output$unformatted_date <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_date,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_date,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_date,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)]))
#'   )
#'   observeEvent(
#'     input$button4_date,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates))
#'   )
#'   observeEvent(
#'     input$button0_date,
#'     fs$set_state(
#'       teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
DateFilterState <- R6::R6Class( # nolint
  "DateFilterState",
  inherit = FilterState,

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `FilterState` object.
    #'
    #' @param x (`Date`)
    #'   variable to be filtered.
    #' @param x_reactive (`reactive`)
    #'   returning vector of the same type as `x`. Is used to update
    #'   counts following the change in values of the filtered dataset.
    #'   If it is set to `reactive(NULL)` then counts based on filtered
    #'   dataset are not shown.
    #' @param slice (`teal_slice`)
    #'   specification of this filter state.
    #'   `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
    #'   `get_state` returns `teal_slice` object which can be reused in other places.
    #'   Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
    #'   changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
    #' @param extract_type (`character`)
    #'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
    #' - `character(0)` (default) `varname` in the condition call will not be prefixed
    #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
    #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
    #'
    #' @return Object of class `DateFilterState`, invisibly.
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          slice,
                          extract_type = character(0)) {
      isolate({
        checkmate::assert_date(x)
        checkmate::assert_class(x_reactive, "reactive")

        super$initialize(
          x = x,
          x_reactive = x_reactive,
          slice = slice,
          extract_type = extract_type
        )
        checkmate::assert_date(slice$choices, null.ok = TRUE)
        private$set_choices(slice$choices)
        if (is.null(slice$selected)) slice$selected <- slice$choices
        private$set_selected(slice$selected)
      })

      invisible(self)
    },

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For this class returned call looks like
    #' `<varname> >= <min value> & <varname> <= <max value>` with optional `is.na(<varname>)`.
    #' @param dataname (`character(1)`) containing possibly prefixed name of data set
    #' @return `call` or `NULL`
    #'
    get_call = function(dataname) {
      if (isFALSE(private$is_any_filtered())) {
        return(NULL)
      }
      choices <- as.character(private$get_selected())
      varname <- private$get_varname_prefixed(dataname)
      filter_call <-
        call(
          "&",
          call(">=", varname, call("as.Date", choices[1L])),
          call("<=", varname, call("as.Date", choices[2L]))
        )
      private$add_keep_na_call(filter_call, varname)
    }
  ),

  # private methods ----

  private = list(
    set_choices = function(choices) {
      if (is.null(choices)) {
        choices <- range(private$x, na.rm = TRUE)
      } else {
        choices_adjusted <- c(
          max(choices[1L], min(private$x, na.rm = TRUE)),
          min(choices[2L], max(private$x, na.rm = TRUE))
        )
        if (any(choices != choices_adjusted)) {
          warning(sprintf(
            "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",
            private$get_varname(), private$get_dataname()
          ))
          choices <- choices_adjusted
        }
        if (choices[1L] >= choices[2L]) {
          warning(sprintf(
            "Invalid choices: lower is higher / equal to upper, or not in range of variable values.
            Setting defaults. Varname: %s, dataname: %s.",
            private$get_varname(), private$get_dataname()
          ))
          choices <- range(private$x, na.rm = TRUE)
        }
      }
      private$set_is_choice_limited(private$x, choices)
      private$x <- private$x[(private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x)]
      private$teal_slice$choices <- choices
      invisible(NULL)
    },

    # @description
    # Check whether the initial choices filter out some values of x and set the flag in case.
    set_is_choice_limited = function(xl, choices) {
      private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE))
      invisible(NULL)
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.Date(values, origin = "1970-01-01")
          if (anyNA(values)) stop()
          values
        },
        error = function(e) stop("Vector of set values must contain values coercible to Date.")
      )
    },
    check_length = function(values) {
      if (length(values) != 2) stop("Vector of set values must have length two.")
      if (values[1] > values[2]) {
        warning(
          sprintf(
            "Start date %s is set after the end date %s, the values will be replaced with a default date range.",
            values[1], values[2]
          )
        )
        values <- isolate(private$get_choices())
      }
      values
    },
    remove_out_of_bounds_values = function(values) {
      choices <- private$get_choices()
      if (values[1] < choices[1L] | values[1] > choices[2L]) {
        warning(
          sprintf(
            "Value: %s is outside of the possible range for column %s of dataset %s, setting minimum possible value.",
            values[1], private$get_varname(), private$get_dataname()
          )
        )
        values[1] <- choices[1L]
      }

      if (values[2] > choices[2L] | values[2] < choices[1L]) {
        warning(
          sprintf(
            "Value: %s is outside of the possible range for column %s of dataset %s, setting maximum possible value.",
            values[2], private$get_varname(), private$get_dataname()
          )
        )
        values[2] <- choices[2L]
      }

      values
    },

    # shiny modules ----

    # @description
    # UI Module for `DateFilterState`.
    # This UI element contains two date selections for `min` and `max`
    # of the range and a checkbox whether to keep the `NA` values.
    # @param id (`character(1)`) `shiny` module instance id.
    ui_inputs = function(id) {
      ns <- NS(id)
      isolate({
        tags$div(
          tags$div(
            class = "flex",
            actionButton(
              class = "date_reset_button",
              inputId = ns("start_date_reset"),
              label = NULL,
              icon = icon("fas fa-undo")
            ),
            tags$div(
              class = "w-80 filter_datelike_input",
              dateRangeInput(
                inputId = ns("selection"),
                label = NULL,
                start = private$get_selected()[1],
                end = private$get_selected()[2],
                min = private$get_choices()[1L],
                max = private$get_choices()[2L],
                width = "100%"
              )
            ),
            actionButton(
              class = "date_reset_button",
              inputId = ns("end_date_reset"),
              label = NULL,
              icon = icon("fas fa-undo")
            )
          ),
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

    # @description
    # Server module
    # @param id (`character(1)`) `shiny` module instance id.
    # @return `NULL`.
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("DateFilterState$server initializing, id: { private$get_id() }")

          # this observer is needed in the situation when teal_slice$selected has been
          # changed directly by the api - then it's needed to rerender UI element
          # to show relevant values
          private$session_bindings[[session$ns("selection_api")]] <- observeEvent(
            ignoreNULL = TRUE, # dates needs to be selected
            ignoreInit = TRUE,
            eventExpr = private$get_selected(),
            handlerExpr = {
              if (!setequal(private$get_selected(), input$selection)) {
                logger::log_debug("DateFilterState$server@1 state changed, id: { private$get_id() }")
                updateDateRangeInput(
                  session = session,
                  inputId = "selection",
                  start = private$get_selected()[1],
                  end = private$get_selected()[2]
                )
              }
            }
          )

          private$session_bindings[[session$ns("selection")]] <- observeEvent(
            ignoreNULL = TRUE, # dates needs to be selected
            ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
            eventExpr = input$selection,
            handlerExpr = {
              logger::log_debug("DateFilterState$server@2 selection changed, id: { private$get_id() }")
              start_date <- input$selection[1]
              end_date <- input$selection[2]

              if (is.na(start_date) || is.na(end_date) || start_date > end_date) {
                updateDateRangeInput(
                  session = session,
                  inputId = "selection",
                  start = private$get_selected()[1],
                  end = private$get_selected()[2]
                )
                showNotification(
                  "Start date must not be greater than the end date. Setting back to previous value.",
                  type = "warning"
                )
                return(NULL)
              }

              private$set_selected(c(start_date, end_date))
            }
          )


          private$keep_na_srv("keep_na")

          private$session_bindings[[session$ns("reset1")]] <- observeEvent(input$start_date_reset, {
            logger::log_debug("DateFilterState$server@3 reset start date, id: { private$get_id() }")
            updateDateRangeInput(
              session = session,
              inputId = "selection",
              start = private$get_choices()[1L]
            )
          })

          private$session_bindings[[session$ns("reset2")]] <- observeEvent(input$end_date_reset, {
            logger::log_debug("DateFilterState$server@4 reset end date, id: { private$get_id() }")
            updateDateRangeInput(
              session = session,
              inputId = "selection",
              end = private$get_choices()[2L]
            )
          })

          NULL
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("DateFilterState$server initializing, id: { private$get_id() }")

          output$selection <- renderUI({
            vals <- format(private$get_selected(), nsmall = 3)
            tags$div(
              tags$div(icon("calendar-days"), vals[1]),
              tags$div(span(" - "), icon("calendar-days"), vals[2])
            )
          })

          NULL
        }
      )
    },

    # @description
    # Server module to display filter summary
    #  renders text describing selected date range and
    #  if NA are included also
    content_summary = function(id) {
      selected <- as.character(private$get_selected())
      min <- selected[1]
      max <- selected[2]
      tagList(
        tags$span(
          class = "filter-card-summary-value",
          HTML(min, "&ndash;", max)
        ),
        tags$span(
          class = "filter-card-summary-controls",
          if (private$na_count > 0) {
            tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
          }
        )
      )
    }
  )
)

# EmptyFilterState ------

#' @name EmptyFilterState
#' @docType class
#'
#' @title `FilterState` object for empty variables
#'
#' @description `FilterState` subclass representing an empty variable.
#'
#' @examples
#' # use non-exported function from teal.slice
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
#' EmptyFilterState <- getFromNamespace("EmptyFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- EmptyFilterState$new(
#'   x = NA,
#'   slice = teal_slice(varname = "x", dataname = "data"),
#'   extract_type = character(0)
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#' isolate(filter_state$get_call())
#'
#' @keywords internal
#'
EmptyFilterState <- R6::R6Class( # nolint
  "EmptyFilterState",
  inherit = FilterState,

  # public methods ----
  public = list(

    #' @description
    #' Initialize `EmptyFilterState` object.
    #'
    #' @param x (`vector`)
    #'   variable to be filtered,
    #' @param x_reactive (`reactive`)
    #'   returning vector of the same type as `x`. Is used to update
    #'   counts following the change in values of the filtered dataset.
    #'   If it is set to `reactive(NULL)` then counts based on filtered
    #'   dataset are not shown.
    #' @param slice (`teal_slice`)
    #'   specification of this filter state.
    #'   `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
    #'   `get_state` returns `teal_slice` object which can be reused in other places.
    #'   Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
    #'   changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
    #' @param extract_type (`character`)
    #'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
    #' - `character(0)` (default) `varname` in the condition call will not be prefixed
    #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
    #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
    #'
    #' @return Object of class `EmptyFilterState`, invisibly.
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          extract_type = character(0),
                          slice) {
      isolate({
        super$initialize(
          x = x,
          x_reactive = x_reactive,
          slice = slice,
          extract_type = extract_type
        )
        private$set_choices(slice$choices)
        private$set_selected(slice$selected)
      })

      invisible(self)
    },

    #' @description
    #' Returns reproducible condition call for current selection relevant for selected variable type.
    #' Uses internal reactive values, hence must be called in reactive or isolated context.
    #' @param dataname name of data set; defaults to `private$get_dataname()`
    #' @return `logical(1)`
    #'
    get_call = function(dataname) {
      if (isFALSE(private$is_any_filtered())) {
        return(NULL)
      }
      if (missing(dataname)) dataname <- private$get_dataname()
      filter_call <- if (isTRUE(private$get_keep_na())) {
        call("is.na", private$get_varname_prefixed(dataname))
      } else {
        substitute(!is.na(varname), list(varname = private$get_varname_prefixed(dataname)))
      }
    }
  ),

  # private members ----
  private = list(
    cache_state = function() {
      private$cache <- private$get_state()
      self$set_state(
        list(
          keep_na = NULL
        )
      )
    },
    set_choices = function(choices) {
      private$teal_slice$choices <- choices
      invisible(NULL)
    },


    # Reports whether the current state filters out any values.(?)
    # @return `logical(1)`
    #
    is_any_filtered = function() {
      if (private$is_choice_limited) {
        TRUE
      } else {
        !isTRUE(private$get_keep_na())
      }
    },

    # @description
    # UI Module for `EmptyFilterState`.
    # This UI element contains a checkbox input to filter or keep missing values.
    # @param id (`character(1)`) `shiny` module instance id.
    #
    ui_inputs = function(id) {
      ns <- NS(id)
      isolate({
        tags$div(
          tags$span("Variable contains missing values only"),
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

    # @description
    # Controls state of the `keep_na` checkbox input.
    #
    # @param id (`character(1)`) `shiny` module instance id.
    #
    # @return `NULL`.
    #
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          private$keep_na_srv("keep_na")
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          output$selection <- renderUI({
            tags$span("Variable contains missing values only")
          })
          NULL
        }
      )
    },

    # @description
    # Server module to display filter summary
    # Doesn't render anything
    content_summary = function(id) {
      tags$span("All empty")
    }
  )
)

# DefaultFilteredDataset ----

#' @name DefaultFilteredDataset
#' @docType class
#' @title `DefaultFilteredDataset` `R6` class
#'
#' @description Stores any object as inert entity. Filtering is not supported.
#'
#' @examples
#' # use non-exported function from teal.slice
#' DefaultFilteredDataset <- getFromNamespace("DefaultFilteredDataset", "teal.slice")
#'
#' library(shiny)
#'
#' ds <- DefaultFilteredDataset$new(letters, "letters")
#' isolate(ds$get_filter_state())
#' isolate(ds$get_call())
#'
#' @keywords internal
#'
DefaultFilteredDataset <- R6::R6Class( # nolint
  classname = "DefaultFilteredDataset",
  inherit = FilteredDataset,

  # public methods ----
  public = list(

    #' @description
    #' Initializes this `DefaultFilteredDataset` object.
    #'
    #' @param dataset
    #'  any type of object; will not be filtered.
    #' @param dataname (`character(1)`)
    #'  syntactically valid name given to the dataset.
    #' @param label (`character(1)`)
    #'   label to describe the dataset.
    #'
    #' @return Object of class `DefaultFilteredDataset`, invisibly.
    #'
    initialize = function(dataset, dataname, label = character(0)) {
      super$initialize(dataset = dataset, dataname = dataname, label = label)
    },

    #' @description
    #' Returns a formatted string representing this `DefaultFilteredDataset` object.
    #'
    #' @param show_all (`logical(1)`) for method consistency, ignored.
    #' @param trim_lines (`logical(1)`) flag specifying whether to trim lines if class names are too long.
    #'
    #' @return The formatted string.
    #'
    format = function(show_all, trim_lines = FALSE) {
      class_string <- toString(class(private$dataset))
      if (trim_lines) {
        trim_position <- 37L
        class_string <- strtrim(class_string, trim_position)
        substr(class_string, 35L, 37L) <- "..."
      }
      sprintf(" - unfiltered dataset:\t\"%s\":   %s", private$dataname, class_string)
    },

    #' @param sid (`character(1)`) for method consistency, ignored.
    #' @return `NULL`, invisibly.
    get_call = function(sid) {
      invisible(NULL)
    },
    #' @return `NULL`, invisibly.
    get_filter_state = function() {
      invisible(NULL)
    },
    #' @param state (`teal_slices`) for method consistency, ignored.
    #' @return `NULL`, invisibly.
    set_filter_state = function(state) {
      if (length(state) != 0L) {
        warning("DefaultFilterState cannot set state")
      }
      invisible(NULL)
    },
    #' @param force (`logical(1)`) for method consistency, ignored.
    #' @return `NULL`, invisibly.
    clear_filter_states = function(force) {
      invisible(NULL)
    },

    #' @description
    #' Creates row for filter overview in the form of \cr
    #' `dataname` - unsupported data class
    #' @return A `data.frame`.
    get_filter_overview = function() {
      data.frame(dataname = private$dataname, obs = NA, obs_filtered = NA)
    },

    # shiny modules ----

    #' @description
    #' Overwrites parent method.
    #' @details
    #' Blank UI module that would list active filter states for this dataset.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param allow_add (ignored)
    #' @return An empty `div`.
    ui_active = function(id, allow_add) {
      ns <- NS(id)
      tags$div()
    },

    #' @description
    #' Overwrites parent method.
    #' @details
    #' Blank UI module that would list active filter states for this dataset.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return An empty `div`.
    ui_add = function(id) {
      ns <- NS(id)
      tags$div()
    }
  ),
  private = list(
    # private methods ----
    # private fields ----
  )
)

#' Set "`<choice>:<label>`" type of names
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is often useful for as it marks up the drop-down boxes for [shiny::selectInput()].
#'
#' @details
#' If either `choices` or `labels` are factors, they are coerced to character.
#' Duplicated elements from `choices` get removed.
#'
#' @param choices (`character` or `numeric` or `logical`) vector
#' @param labels (`character`) vector containing labels to be applied to `choices`. If `NA` then
#' "Label Missing" will be used.
#' @param subset a vector that is a subset of `choices`. This is useful if
#'   only a few variables need to be named. If this argument is used, the returned vector will
#'   match its order.
#' @param types vector containing the types of the columns.
#'
#' @return A named character vector.
#'
#' @keywords internal
#'
choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
  if (is.factor(choices)) {
    choices <- as.character(choices)
  }

  stopifnot(
    is.character(choices) ||
      is.numeric(choices) ||
      is.logical(choices) ||
      (length(choices) == 1 && is.na(choices))
  )

  if (is.factor(labels)) {
    labels <- as.character(labels)
  }

  checkmate::assert_character(labels[!is.na(labels)], any.missing = FALSE)
  if (length(choices) != length(labels)) {
    stop("length of choices must be the same as labels")
  }
  stopifnot(is.null(subset) || is.vector(subset))
  stopifnot(is.null(types) || is.vector(types))

  if (is.vector(types)) {
    stopifnot(length(choices) == length(types))
  }

  if (!is.null(subset)) {
    if (!all(subset %in% choices)) {
      stop("all of subset variables must be in choices")
    }
    labels <- labels[choices %in% subset]
    types <- types[choices %in% subset]
    choices <- choices[choices %in% subset]
  }

  is_dupl <- duplicated(choices)
  choices <- choices[!is_dupl]
  labels <- labels[!is_dupl]
  types <- types[!is_dupl]
  labels[is.na(labels)] <- "Label Missing"
  raw_labels <- labels
  combined_labels <- if (length(choices) > 0) {
    paste0(choices, ": ", labels)
  } else {
    character(0)
  }

  if (!is.null(subset)) {
    ord <- match(subset, choices)
    choices <- choices[ord]
    raw_labels <- raw_labels[ord]
    combined_labels <- combined_labels[ord]
    types <- types[ord]
  }
  choices <- structure(
    choices,
    names = combined_labels,
    raw_labels = raw_labels,
    combined_labels = combined_labels,
    class = c("choices_labeled", "character"),
    types = types
  )

  choices
}

#' Initialize `FilteredData`
#'
#' Function creates a `FilteredData` object.
#'
#' @param x (`named list`) of datasets.
#' @param join_keys (`join_keys`) see [`teal.data::join_keys()`].
#'
#' @return Object of class `FilteredData`.
#'
#' @examples
#' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars))
#' datasets
#'
#' @export
init_filtered_data <- function(x, join_keys = teal.data::join_keys()) { # nolint
  checkmate::assert_list(x, any.missing = FALSE, names = "unique")
  checkmate::assert_class(join_keys, "join_keys")
  FilteredData$new(x, join_keys = join_keys)
}

#' Evaluate expression with meaningful message
#'
#' Method created for the `FilteredData` object to execute filter call with
#' meaningful message. After evaluation used environment should contain
#' all necessary bindings.
#'
#' @param expr (`language`)
#' @param env (`environment`) where expression is evaluated.
#' @return `NULL`, invisibly.
#' @keywords internal
eval_expr_with_msg <- function(expr, env) {
  lapply(
    expr,
    function(x) {
      tryCatch(
        eval(x, envir = env),
        error = function(e) {
          stop(
            sprintf(
              "Filter call execution failed:\n - call:\n   %s\n - message:\n   %s ",
              deparse1(x, collapse = "\n"), e
            )
          )
        }
      )
    }
  )
  invisible(NULL)
}


#' Toggle button properties.
#'
#' Switch between different icons or titles on a button.
#'
#' Wrapper functions that use `shinyjs::runjs` to change button properties in response to events,
#' typically clicking those very buttons.
#' `shiny`'s `actionButton` and `actionLink` create `<a>` tags,
#' which may contain a child `<i>` tag that specifies an icon to be displayed.
#' `toggle_icon` calls the `toggleClass` (when `one_way = FALSE`) or
#' `removeClass` and `addClass` methods (when `one_way = TRUE`) to change icons.
#' `toggle_title` calls the `attr` method to modify the `Title` attribute of the button.
#'
#' @param input_id (`character(1)`) (name-spaced) id of the button
#' @param icons,titles (`character(2)`) vector specifying values between which to toggle
#' @param one_way (`logical(1)`) flag specifying whether to keep toggling;
#'                if TRUE, the target will be changed
#'                from the first element of `icons`/`titles` to the second
#'
#' @return `NULL`, invisibly.
#'
#' @examples
#' # use non-exported function from teal.slice
#' toggle_icon <- getFromNamespace("toggle_icon", "teal.slice")
#'
#' library(shiny)
#' library(shinyjs)
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   actionButton("hide_content", label = "hide", icon = icon("xmark")),
#'   actionButton("show_content", label = "show", icon = icon("check")),
#'   actionButton("toggle_content", label = "toggle", icon = icon("angle-down")),
#'   tags$br(),
#'   tags$div(
#'     id = "content",
#'     verbatimTextOutput("printout")
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   observeEvent(input$hide_content,
#'     {
#'       hide("content")
#'       toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE)
#'     },
#'     ignoreInit = TRUE
#'   )
#'
#'   observeEvent(input$show_content,
#'     {
#'       show("content")
#'       toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE)
#'     },
#'     ignoreInit = TRUE
#'   )
#'
#'   observeEvent(input$toggle_content,
#'     {
#'       toggle("content")
#'       toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"))
#'     },
#'     ignoreInit = TRUE
#'   )
#'
#'   output$printout <- renderPrint({
#'     head(faithful, 10)
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @name toggle_button
#' @rdname toggle_button
#' @keywords internal
toggle_icon <- function(input_id, icons, one_way = FALSE) {
  checkmate::assert_string(input_id)
  checkmate::assert_character(icons, len = 2L)
  checkmate::assert_flag(one_way)

  expr <-
    if (one_way) {
      sprintf(
        "$('#%s i').removeClass('%s').addClass('%s');",
        input_id, icons[1], icons[2]
      )
    } else {
      sprintf("$('#%s i').toggleClass('%s');", input_id, paste(icons, collapse = " "))
    }

  shinyjs::runjs(expr)

  invisible(NULL)
}

#' @rdname toggle_button
#' @keywords internal
toggle_title <- function(input_id, titles, one_way = FALSE) {
  checkmate::assert_string(input_id)
  checkmate::assert_character(titles, len = 2L)
  checkmate::assert_flag(one_way)

  expr <-
    if (one_way) {
      sprintf(
        "$('a#%s').attr('title', '%s');",
        input_id, titles[2]
      )
    } else {
      sprintf(
        paste0(
          "var button_id = 'a#%1$s';",
          "var curr = $(button_id).attr('title');",
          "if (curr == '%2$s') { $(button_id).attr('title', '%3$s');",
          "} else { $(button_id).attr('title', '%2$s');",
          "}"
        ),
        input_id, titles[1], titles[2]
      )
    }

  shinyjs::runjs(expr)

  invisible(NULL)
}

#' @inherit teal.data::topological_sort description details params title
#' @examples
#' # use non-exported function from teal.slice
#' topological_sort <- getFromNamespace("topological_sort", "teal.slice")
#'
#' topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
#' topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
#' topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
#' @keywords internal
topological_sort <- function(graph) {
  utils::getFromNamespace("topological_sort", ns = "teal.data")(graph)
}

# FilterPanelAPI ------

#' @name FilterPanelAPI
#' @docType class
#'
#' @title Class to encapsulate the API of the filter panel of a teal app
#'
#' @description
#' An API class for managing filter states in a teal application's filter panel.
#'
#' @details
#' The purpose of this class is to encapsulate the API of the filter panel in a
#' new class `FilterPanelAPI` so that it can be passed and used in the server
#' call of any module instead of passing the whole `FilteredData` object.
#'
#' This class is supported by methods to set, get, remove filter states in the
#' filter panel API.
#'
#' @examples
#' library(shiny)
#'
#' fd <- init_filtered_data(list(iris = iris))
#' fpa <- FilterPanelAPI$new(fd)
#'
#' # get the actual filter state --> empty named list
#' isolate(fpa$get_filter_state())
#'
#' # set a filter state
#' set_filter_state(
#'   fpa,
#'   teal_slices(
#'     teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)
#'   )
#' )
#'
#' # get the actual filter state --> named list with filters
#' isolate(fpa$get_filter_state())
#'
#' # remove all_filter_states
#' fpa$clear_filter_states()
#'
#' # get the actual filter state --> empty named list
#' isolate(fpa$get_filter_state())
#'
#' @export
#'
FilterPanelAPI <- R6::R6Class( # nolint
  "FilterPanelAPI",
  # public methods ----
  public = list(
    #' @description
    #' Initialize a `FilterPanelAPI` object.
    #' @param datasets (`FilteredData`)
    #'
    initialize = function(datasets) {
      checkmate::assert_class(datasets, "FilteredData")
      private$filtered_data <- datasets
    },

    #' @description
    #' Gets the reactive values from the active `FilterState` objects of the `FilteredData` object.
    #'
    #' Gets all active filters in the form of a nested list.
    #' The output list is a compatible input to `set_filter_state`.
    #'
    #' @return `list` with named elements corresponding to `FilteredDataset` objects with active filters.
    #'
    get_filter_state = function() {
      private$filtered_data$get_filter_state()
    },

    #' @description
    #' Sets active filter states.
    #' @param filter (`teal_slices`)
    #'
    #' @return `NULL`, invisibly.
    #'
    set_filter_state = function(filter) {
      private$filtered_data$set_filter_state(filter)
      invisible(NULL)
    },

    #' @description
    #' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object.
    #'
    #' @param filter (`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(filter) {
      private$filtered_data$remove_filter_state(filter)
      invisible(NULL)
    },

    #' @description
    #' Remove all `FilterStates` of the `FilteredData` object.
    #'
    #' @param datanames (`character`)
    #'  `datanames` to remove their `FilterStates`;
    #'  omit to remove all `FilterStates` in the `FilteredData` object
    #'
    #' @return `NULL`, invisibly.
    #'
    clear_filter_states = function(datanames) {
      datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames
      private$filtered_data$clear_filter_states(datanames = datanames_to_remove)
      invisible(NULL)
    }
  ),
  # private methods ----
  private = list(
    filtered_data = NULL
  )
)

#' Initialize `FilterStates` object
#'
#' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`)
#'   object to subset.
#' @param data_reactive (`function(sid)`)
#'   should return an object of the same type as `data` or `NULL`.
#'   This function is needed for the `FilterState` `shiny` module to update counts if filtered data changes.
#'   If function returns `NULL` then filtered counts are not shown.
#'   Function has to have `sid` argument being a character which is related to `sid` argument in the `get_call` method.
#' @param dataname (`character(1)`)
#'   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 ... optional,
#'   additional arguments for specific classes: keys.
#'
#' @return Object of class `FilterStates`.
#'
#' @keywords internal
#' @examples
#' # use non-exported function from teal.slice
#' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
#'
#' df <- data.frame(
#'   character = letters,
#'   numeric = seq_along(letters),
#'   date = seq(Sys.Date(), length.out = length(letters), by = "1 day"),
#'   datetime = seq(Sys.time(), length.out = length(letters), by = "33.33 hours")
#' )
#' rf <- init_filter_states(
#'   data = df,
#'   dataname = "DF"
#' )
#'
#' library(shiny)
#' ui <- fluidPage(
#'   actionButton("clear", tags$span(icon("xmark"), "Remove all filters")),
#'   rf$ui_add(id = "add"),
#'   rf$ui_active("states"),
#'   verbatimTextOutput("expr"),
#' )
#'
#' server <- function(input, output, session) {
#'   rf$srv_add(id = "add")
#'   rf$srv_active(id = "states")
#'   output$expr <- renderText({
#'     deparse1(rf$get_call(), collapse = "\n")
#'   })
#'   observeEvent(input$clear, rf$clear_filter_states())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @export
#'
init_filter_states <- function(data,
                               data_reactive = reactive(NULL),
                               dataname,
                               datalabel = NULL,
                               ...) {
  UseMethod("init_filter_states")
}

#' @keywords internal
#' @export
init_filter_states.data.frame <- function(data, # nolint
                                          data_reactive = function(sid = "") NULL,
                                          dataname,
                                          datalabel = NULL,
                                          keys = character(0),
                                          ...) {
  DFFilterStates$new(
    data = data,
    data_reactive = data_reactive,
    dataname = dataname,
    datalabel = datalabel,
    keys = keys
  )
}

#' @keywords internal
#' @export
init_filter_states.matrix <- function(data, # nolint
                                      data_reactive = function(sid = "") NULL,
                                      dataname,
                                      datalabel = NULL,
                                      ...) {
  MatrixFilterStates$new(
    data = data,
    data_reactive = data_reactive,
    dataname = dataname,
    datalabel = datalabel
  )
}

#' @keywords internal
#' @export
init_filter_states.MultiAssayExperiment <- function(data, # nolint
                                                    data_reactive = function(sid = "") NULL,
                                                    dataname,
                                                    datalabel = "subjects",
                                                    keys = character(0),
                                                    ...) {
  if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
    stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
  }
  MAEFilterStates$new(
    data = data,
    data_reactive = data_reactive,
    dataname = dataname,
    datalabel = datalabel,
    keys = keys
  )
}

#' @keywords internal
#' @export
init_filter_states.SummarizedExperiment <- function(data, # nolint
                                                    data_reactive = function(sid = "") NULL,
                                                    dataname,
                                                    datalabel = NULL,
                                                    ...) {
  if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
    stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
  }
  SEFilterStates$new(
    data = data,
    data_reactive = data_reactive,
    dataname = dataname,
    datalabel = datalabel
  )
}

#' Gets supported filterable variable names
#'
#' Gets filterable variable names from a given object. The names match variables
#' of classes in an vector `teal.slice:::.filterable_class`.
#' @param data
#'   the `R` object containing elements which class can be checked through `vapply` or `apply`.
#' @return `character` vector of variable names.
#' @examples
#' # use non-exported function from teal.slice
#' get_supported_filter_varnames <- getFromNamespace("get_supported_filter_varnames", "teal.slice")
#'
#' df <- data.frame(
#'   a = letters[1:3],
#'   b = 1:3,
#'   c = Sys.Date() + 1:3,
#'   d = Sys.time() + 1:3,
#'   z = complex(3)
#' )
#' get_supported_filter_varnames(df)
#' @keywords internal
#' @export
get_supported_filter_varnames <- function(data) {
  UseMethod("get_supported_filter_varnames")
}

#' @keywords internal
#' @export
get_supported_filter_varnames.default <- function(data) { # nolint
  is_expected_class <- vapply(
    X = data,
    FUN = function(x) any(class(x) %in% .filterable_class),
    FUN.VALUE = logical(1)
  )
  names(is_expected_class[is_expected_class])
}

#' @keywords internal
#' @export
get_supported_filter_varnames.matrix <- function(data) { # nolint
  # all columns are the same type in matrix
  is_expected_class <- class(data[, 1]) %in% .filterable_class
  if (is_expected_class && !is.null(colnames(data))) {
    colnames(data)
  } else {
    character(0)
  }
}

#' @keywords internal
#' @export
get_supported_filter_varnames.MultiAssayExperiment <- function(data) { # nolint
  data <- SummarizedExperiment::colData(data)
  # all columns are the same type in matrix
  is_expected_class <- class(data[, 1]) %in% .filterable_class
  if (is_expected_class && !is.null(names(data))) {
    names(data)
  } else {
    character(0)
  }
}

#' Returns a `choices_labeled` object
#'
#' @param data (`data.frame` or `DFrame` or `list`)
#'   where labels can be taken from in case when `varlabels` is not specified.
#'   `data` must be specified if `varlabels` is not specified.
#' @param choices (`character`)
#'  the vector of chosen variables
#' @param varlabels (`character`)
#'  the labels of variables in data
#' @param keys (`character`)
#'  the names of the key columns in data
#' @return `character(0)` if choices are empty; a `choices_labeled` object otherwise
#' @keywords internal
data_choices_labeled <- function(data,
                                 choices,
                                 varlabels = teal.data::col_labels(data, fill = TRUE),
                                 keys = character(0)) {
  if (length(choices) == 0) {
    return(character(0))
  }
  choice_types <- variable_types(data = data, columns = choices)
  choice_types[keys] <- "primary_key"

  choices_labeled(
    choices = choices,
    labels = unname(varlabels[choices]),
    types = choice_types[choices]
  )
}

#' @noRd
#' @keywords internal
get_varlabels <- function(data) {
  if (!is.array(data)) {
    vapply(
      colnames(data),
      FUN = function(x) {
        label <- attr(data[[x]], "label")
        if (is.null(label)) {
          x
        } else {
          label
        }
      },
      FUN.VALUE = character(1)
    )
  } else {
    character(0)
  }
}

# MAEFilterStates ------

#' @name MAEFilterStates
#' @docType class
#' @title `FilterStates` subclass for `MultiAssayExperiment`s
#' @description Handles filter states in a `MultiAssayExperiment`.
#' @keywords internal
#'
MAEFilterStates <- R6::R6Class( # nolint
  classname = "MAEFilterStates",
  inherit = FilterStates,
  # public methods ----
  public = list(
    #' @description
    #' Initialize `MAEFilterStates` object.
    #'
    #' @param data (`MultiAssayExperiment`)
    #'   the `R` object which `MultiAssayExperiment::subsetByColData` function is applied on.
    #' @param data_reactive (`function(sid)`)
    #'   should return a `MultiAssayExperiment` 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 data used in the subset expression.
    #'   Passed to the function argument attached to this `FilterStates`.
    #' @param datalabel (`character(1)`) optional
    #'   text label.
    #' @param varlabels (`character`)
    #'   labels of the variables used in this object.
    #' @param keys (`character`)
    #'   key column names.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = "subjects",
                          keys = character(0)) {
      if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
        stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
      }
      checkmate::assert_function(data_reactive, args = "sid")
      checkmate::assert_class(data, "MultiAssayExperiment")

      data <- SummarizedExperiment::colData(data)
      data_reactive <- function(sid = "") SummarizedExperiment::colData(data_reactive(sid = sid))
      super$initialize(data, data_reactive, dataname, datalabel)
      private$keys <- keys
      private$set_filterable_varnames(include_varnames = colnames(data))

      invisible(self)
    }
  ),

  # private fields ----

  private = list(
    extract_type = "list",
    fun = quote(MultiAssayExperiment::subsetByColData)
  )
)

#' Include `CSS` files from `/inst/css/` package directory to application header
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`. Therefore, we redefine this method in each package
#' as needed. Thus, we do not export this method.
#'
#' @param pattern (`character`) pattern of files to be included
#'
#' @return HTML code that includes `CSS` files
#' @keywords internal
include_css_files <- function(pattern = "*") {
  css_files <- list.files(
    system.file("css", package = "teal.slice", mustWork = TRUE),
    pattern = pattern, full.names = TRUE
  )
  singleton(tags$head(lapply(css_files, includeCSS)))
}

# This file contains helper functions used in unit tests.

# compares specified fields between two `teal_slice` objects
#' @noRd
#' @keywords internal
compare_slices <- function(ts1, ts2, fields) {
  isolate(
    all(vapply(fields, function(x) identical(ts1[[x]], ts2[[x]]), logical(1L)))
  )
}


# compare two teal_slice
#' @noRd
#' @keywords internal
expect_identical_slice <- function(x, y) {
  isolate({
    testthat::expect_true(
      setequal(
        reactiveValuesToList(x),
        reactiveValuesToList(y)
      )
    )
  })
}

# compare two teal_slices
#' @noRd
#' @keywords internal
expect_identical_slices <- function(x, y) {
  isolate({
    mapply(
      function(x, y) {
        expect_identical_slice(x, y)
      },
      x = x,
      y = y
    )
    testthat::expect_identical(attributes(x), attributes(y))
  })
}

#' Managing `FilteredData` states
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Set, get and remove filter states of `FilteredData` object.
#'
#' @name filter_state_api
#'
#' @param datasets (`FilteredData`)
#'   object to store filter state and filtered datasets, shared across modules
#'
#'   see [`FilteredData`] for details
#'
#' @param filter (`teal_slices`)
#'   specify filters in place on app start-up
#'
#' @param force (`logical(1)`)
#'   flag specifying whether to include anchored filter states.
#'
#' @return
#' - `set_*`, `remove_*` and `clear_filter_state` return `NULL` invisibly
#' - `get_filter_state` returns a named `teal_slices` object
#'    containing a `teal_slice` for every existing `FilterState`
#'
#' @seealso [`teal_slice`]
#'
#' @examples
#' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars))
#' fs <- teal_slices(
#'   teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor")),
#'   teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)),
#'   teal_slice(dataname = "mtcars", varname = "gear", selected = c(4, 5)),
#'   teal_slice(dataname = "mtcars", varname = "carb", selected = c(4, 10))
#' )
#'
#' # set initial filter state
#' set_filter_state(datasets, filter = fs)
#'
#' # get filter state
#' get_filter_state(datasets)
#'
#' # modify filter state
#' set_filter_state(
#'   datasets,
#'   teal_slices(
#'     teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)
#'   )
#' )
#'
#' # remove specific filters
#' remove_filter_state(
#'   datasets,
#'   teal_slices(
#'     teal_slice(dataname = "iris", varname = "Species"),
#'     teal_slice(dataname = "mtcars", varname = "gear"),
#'     teal_slice(dataname = "mtcars", varname = "carb")
#'   )
#' )
#'
#' # remove all states
#' clear_filter_states(datasets)
#'
#' @examples
#' \donttest{
#' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
#'   # Requires MultiAssayExperiment from Bioconductor
#'   data(miniACC, package = "MultiAssayExperiment")
#'
#'   datasets <- init_filtered_data(list(mae = miniACC))
#'   fs <- teal_slices(
#'     teal_slice(
#'       dataname = "mae", varname = "years_to_birth", selected = c(30, 50),
#'       keep_na = TRUE, keep_inf = FALSE
#'     ),
#'     teal_slice(
#'       dataname = "mae", varname = "vital_status", selected = "1",
#'       keep_na = FALSE
#'     ),
#'     teal_slice(
#'       dataname = "mae", varname = "gender", selected = "female",
#'       keep_na = TRUE
#'     ),
#'     teal_slice(
#'       dataname = "mae", varname = "ARRAY_TYPE", selected = "",
#'       keep_na = TRUE, experiment = "RPPAArray", arg = "subset"
#'     )
#'   )
#'
#'   # set initial filter state
#'   set_filter_state(datasets, filter = fs)
#'
#'   # get filter state
#'   get_filter_state(datasets)
#'
#'   # modify filter state
#'   set_filter_state(
#'     datasets,
#'     teal_slices(
#'       teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(40, 60))
#'     )
#'   )
#'
#'   # remove specific filters
#'   remove_filter_state(
#'     datasets,
#'     teal_slices(
#'       teal_slice(dataname = "mae", varname = "years_to_birth"),
#'       teal_slice(dataname = "mae", varname = "vital_status")
#'     )
#'   )
#'
#'   # remove all states
#'   clear_filter_states(datasets)
#' }
#' }
NULL

#' @rdname filter_state_api
#' @export
set_filter_state <- function(datasets, filter) {
  checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
  checkmate::assert_class(filter, "teal_slices")
  datasets$set_filter_state(filter)
  invisible(NULL)
}

#' @rdname filter_state_api
#' @export
get_filter_state <- function(datasets) {
  checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
  if (isRunning()) {
    datasets$get_filter_state()
  } else {
    isolate(datasets$get_filter_state())
  }
}

#' @rdname filter_state_api
#' @export
remove_filter_state <- function(datasets, filter) {
  checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
  checkmate::assert_class(filter, "teal_slices")

  datasets$remove_filter_state(filter)
  invisible(NULL)
}

#' @rdname filter_state_api
#' @export
clear_filter_states <- function(datasets, force = FALSE) {
  checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
  datasets$clear_filter_states(force = force)
  invisible(NULL)
}

#' Gets filter expression for multiple `datanames` taking into account its order.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' To be used in `Show R Code` button.
#'
#' @param datasets (`FilteredData`)
#' @param datanames (`character`) vector of dataset names
#'
#' @return A character string containing all subset expressions.
#'
#' @export
#'
get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
  checkmate::check_class(datasets, "FilteredData")
  checkmate::assert_character(datanames, any.missing = FALSE)
  checkmate::assert_subset(datanames, datasets$datanames())
  paste(
    unlist(lapply(
      datanames,
      function(dataname) {
        datasets$get_call(dataname)
      }
    )),
    collapse = "\n"
  )
}

# 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)
  )
)

#' Initialize `FilteredDataset`
#'
#' Initializes a `FilteredDataset` object corresponding to the class of the filtered dataset.
#'
#' @param dataset any object
#' @param dataname (`character(1)`)
#'   syntactically valid name given to the dataset.
#' @param keys (`character`) optional
#'   vector of primary key column names.
#' @param parent_name (`character(1)`)
#'   name of the parent dataset.
#' @param parent (`reactive`)
#'   that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`.
#'   Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset`
#'   based on the changes in `parent`.
#' @param join_keys (`character`)
#'   vector of names of columns in this dataset to join with `parent` dataset.
#'   If column names in the parent do not match these, they should be given as the names of this vector.
#' @param label (`character(1)`)
#'   label to describe the dataset.
#'
#' @return Object of class `FilteredDataset`.
#'
#' @section Warning:
#' This function is exported to allow other packages to extend `teal.slice` but it is treated as internal.
#' Breaking changes may occur without warning.
#' We recommend consulting the package maintainer before using it.
#'
#' @examples
#' # DataframeFilteredDataset example
#' library(shiny)
#'
#' iris_fd <- init_filtered_dataset(iris, dataname = "iris")
#' ui <- fluidPage(
#'   iris_fd$ui_add(id = "add"),
#'   iris_fd$ui_active("dataset"),
#'   verbatimTextOutput("call")
#' )
#' server <- function(input, output, session) {
#'   iris_fd$srv_add(id = "add")
#'   iris_fd$srv_active(id = "dataset")
#'
#'   output$call <- renderText({
#'     paste(
#'       vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),
#'       collapse = "\n"
#'     )
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @examples
#' \donttest{
#' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
#'   # MAEFilteredDataset example
#'   library(shiny)
#'
#'   data(miniACC, package = "MultiAssayExperiment")
#'
#'   MAE_fd <- init_filtered_dataset(miniACC, "MAE")
#'   ui <- fluidPage(
#'     MAE_fd$ui_add(id = "add"),
#'     MAE_fd$ui_active("dataset"),
#'     verbatimTextOutput("call")
#'   )
#'   server <- function(input, output, session) {
#'     MAE_fd$srv_add(id = "add")
#'     MAE_fd$srv_active(id = "dataset")
#'     output$call <- renderText({
#'       paste(
#'         vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),
#'         collapse = "\n"
#'       )
#'     })
#'   }
#'   if (interactive()) {
#'     shinyApp(ui, server)
#'   }
#' }
#' }
#' @keywords internal
#' @export
init_filtered_dataset <- function(dataset,
                                  dataname,
                                  keys = character(0),
                                  parent_name = character(0),
                                  parent = reactive(dataset),
                                  join_keys = character(0),
                                  label = attr(dataset, "label", exact = TRUE)) {
  UseMethod("init_filtered_dataset")
}

#' @keywords internal
#' @export
init_filtered_dataset.data.frame <- function(dataset,
                                             dataname,
                                             keys = character(0),
                                             parent_name = character(0),
                                             parent = NULL,
                                             join_keys = character(0),
                                             label = attr(dataset, "label", exact = TRUE)) {
  DataframeFilteredDataset$new(
    dataset = dataset,
    dataname = dataname,
    keys = keys,
    parent_name = parent_name,
    parent = parent,
    join_keys = join_keys,
    label = label
  )
}

#' @keywords internal
#' @export
init_filtered_dataset.MultiAssayExperiment <- function(dataset,
                                                       dataname,
                                                       keys = character(0),
                                                       parent_name, # ignored
                                                       parent, # ignored
                                                       join_keys, # ignored
                                                       label = attr(dataset, "label", exact = TRUE)) {
  if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
    stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
  }
  MAEFilteredDataset$new(
    dataset = dataset,
    dataname = dataname,
    keys = keys,
    label = label
  )
}

#' @keywords internal
#' @export
init_filtered_dataset.default <- function(dataset,
                                          dataname,
                                          keys, # ignored
                                          parent_name, # ignored
                                          parent, # ignored
                                          join_keys, # ignored
                                          label = attr(dataset, "label", exact = TRUE)) {
  DefaultFilteredDataset$new(
    dataset = dataset,
    dataname = dataname,
    label = label
  )
}

# MatrixFilterStates ------

#' @name MatrixFilterStates
#' @docType class
#' @title `FilterStates` subclass for matrices
#' @description Handles filter states in a `matrix`.
#' @keywords internal
#'
MatrixFilterStates <- R6::R6Class( # nolint
  classname = "MatrixFilterStates",
  inherit = FilterStates,

  # public methods ----
  public = list(
    #' @description
    #' Initialize `MatrixFilterStates` object.
    #'
    #' @param data (`matrix`)
    #'   the `R` object which `subset` function is applied on.
    #' @param data_reactive (`function(sid)`)
    #'   should return a `matrix` 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 data used in the subset expression.
    #'   Passed to the function argument attached to this `FilterStates`.
    #' @param datalabel (`character(1)`) optional
    #'   text label. Should be a name of experiment.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL) {
      checkmate::assert_matrix(data)
      super$initialize(data, data_reactive, dataname, datalabel)
      private$set_filterable_varnames(include_varnames = colnames(private$data))
      if (!is.null(datalabel)) {
        private$dataname_prefixed <- sprintf(
          "%s[['%s']]", private$dataname_prefixed, datalabel
        )
      }
    }
  ),
  private = list(
    extract_type = "matrix"
  )
)

1		# FilteredDataset abstract --------
2
3		#' @name FilteredDataset
4		#' @docType class
5		#'
6		#' @title `FilteredDataset` `R6` class
7		#' @description
8		#' `FilteredDataset` is a class which renders/controls `FilterStates`(s)
9		#' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one
10		#' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects.
11		#' Each `FilterStates` is responsible for one filter/subset expression applied for specific
12		#' components of the dataset.
13		#'
14		#' @keywords internal
15		FilteredDataset <- R6::R6Class( # nolint
16		"FilteredDataset",
17		# public methods ----
18		public = list(
19		#' @description
20		#' Initializes this `FilteredDataset` object.
21		#'
22		#' @param dataset any object
23		#' @param dataname (`character(1)`)
24		#' syntactically valid name given to the dataset.
25		#' @param keys (`character`) optional
26		#' vector of primary key column names.
27		#' @param label (`character(1)`)
28		#' label to describe the dataset.
29		#'
30		#' @return Object of class `FilteredDataset`, invisibly.
31		#'
32		initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label", exact = TRUE)) {
33	147x	checkmate::assert_string(dataname)
34	145x	logger::log_debug("Instantiating { class(self)[1] }, dataname: { dataname }")
35	145x	checkmate::assert_character(keys, any.missing = FALSE)
36	145x	checkmate::assert_character(label, null.ok = TRUE)
37	145x	private$dataset <- dataset
38	145x	private$dataname <- dataname
39	145x	private$keys <- keys
40	145x	private$label <- if (is.null(label)) character(0) else label
41
42		# function executing reactive call and returning data
43	145x	private$data_filtered_fun <- function(sid = "") {
44	24x	checkmate::assert_character(sid)
45	24x	if (length(sid)) {
46	24x	logger::log_debug("filtering data dataname: { dataname }, sid: { sid }")
47		} else {
48	!	logger::log_debug("filtering data dataname: { dataname }")
49		}
50	24x	env <- new.env(parent = parent.env(globalenv()))
51	24x	env[[dataname]] <- private$dataset
52	24x	filter_call <- self$get_call(sid)
53	24x	eval_expr_with_msg(filter_call, env)
54	24x	get(x = dataname, envir = env)
55		}
56
57	145x	private$data_filtered <- reactive(private$data_filtered_fun())
58	145x	invisible(self)
59		},
60
61		#' @description
62		#' Returns a formatted string representing this `FilteredDataset` object.
63		#'
64		#' @param show_all (`logical(1)`) passed to `format.teal_slice`.
65		#' @param trim_lines (`logical(1)`) passed to `format.teal_slice`.
66		#'
67		#' @return The formatted character string.
68		#'
69		format = function(show_all = FALSE, trim_lines = TRUE) {
70	24x	sprintf(
71	24x	"%s:\n%s",
72	24x	class(self)[1],
73	24x	format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)
74		)
75		},
76
77		#' @description
78		#' Prints this `FilteredDataset` object.
79		#'
80		#' @param ... additional arguments passed to `format`.
81		#'
82		print = function(...) {
83	10x	cat(isolate(self$format(...)), "\n")
84		},
85
86		#' @description
87		#' Removes all filter items applied to this dataset.
88		#'
89		#' @param force (`logical(1)`)
90		#' flag specifying whether to include anchored filter states.
91		#'
92		#' @return `NULL`.
93		clear_filter_states = function(force = FALSE) {
94	14x	logger::log_debug("Removing filters from FilteredDataset: { private$dataname }")
95	14x	lapply(
96	14x	private$get_filter_states(),
97	14x	function(filter_states) filter_states$clear_filter_states(force)
98		)
99	14x	NULL
100		},
101
102		# managing filter states -----
103
104		# getters ----
105		#' @description
106		#' Gets a filter expression.
107		#'
108		#' This function returns filter calls equivalent to selected items
109		#' within each of `filter_states`. Configuration of the calls is constant and
110		#' depends on `filter_states` type and order which are set during initialization.
111		#'
112		#' @param sid (`character`)
113		#' when specified, the method returns code containing conditions calls of
114		#' `FilterState` objects with `sid` different to this `sid` argument.
115		#'
116		#' @return Either a `list` of filter `call`s, or `NULL`.
117		get_call = function(sid = "") {
118	47x	filter_call <- Filter(
119	47x	f = Negate(is.null),
120	47x	x = lapply(private$get_filter_states(), function(x) x$get_call(sid))
121		)
122	47x	if (length(filter_call) == 0) {
123	29x	return(NULL)
124		}
125	18x	filter_call
126		},
127
128		#' @description
129		#' Gets states of all contained `FilterState` objects.
130		#'
131		#' @return A `teal_slices` object.
132		#'
133		get_filter_state = function() {
134	150x	states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state()))
135	150x	do.call(c, states)
136		},
137
138		#' @description
139		#' Set filter state.
140		#'
141		#' @param state (`teal_slices`)
142		#'
143		#' @return Virtual method, returns nothing and raises error.
144		#'
145		set_filter_state = function(state) {
146	!	stop("set_filter_state is an abstract class method.")
147		},
148
149		#' @description
150		#' Gets the name of the dataset.
151		#'
152		#' @return A character string.
153		get_dataname = function() {
154	8x	private$dataname
155		},
156
157		#' @description
158		#' Gets the dataset object in this `FilteredDataset`.
159		#'
160		#' @param filtered (`logical(1)`)
161		#'
162		#' @return
163		#' The stored dataset. If `data.frame` or `MultiAssayExperiment`,
164		#' either raw or as a reactive with current filters applied (depending on `filtered`).
165		#'
166		get_dataset = function(filtered = FALSE) {
167	51x	if (filtered) {
168	33x	private$data_filtered
169		} else {
170	18x	private$dataset
171		}
172		},
173
174		#' @description
175		#' Get filter overview of a dataset.
176		#' @return Virtual method, returns nothing and raises an error.
177		get_filter_overview = function() {
178	!	stop("get_filter_overview is an abstract class method")
179		},
180
181		#' @description
182		#' Gets the key columns for this dataset.
183		#' @return Character vector of variable names
184		get_keys = function() {
185	127x	private$keys
186		},
187
188		#' @description
189		#' Gets the dataset label.
190		#' @return Character string.
191		get_dataset_label = function() {
192	2x	private$label
193		},
194
195		# modules ------
196		#' @description
197		#' `shiny` module containing active filters for a dataset, along with a title and a remove button.
198		#' @param id (`character(1)`)
199		#' `shiny` module instance id.
200		#' @param allow_add (`logical(1)`)
201		#' logical flag specifying whether the user will be able to add new filters
202		#'
203		#' @return `shiny.tag`
204		ui_active = function(id, allow_add = TRUE) {
205	!	dataname <- self$get_dataname()
206	!	checkmate::assert_string(dataname)
207
208	!	ns <- NS(id)
209	!	if_multiple_filter_states <- length(private$get_filter_states()) > 1
210	!	tags$span(
211	!	id = id,
212	!	class = "teal-slice",
213	!	include_css_files("filter-panel"),
214	!	include_js_files(pattern = "icons"),
215	!	bslib::accordion(
216	!	id = ns("dataset_filter_accordian"),
217	!	class = "teal-slice-dataset-filter",
218	!	bslib::accordion_panel(
219	!	dataname,
220	!	style = "padding: 0; margin: 0;",
221	!	bslib::page_fluid(
222	!	id = ns("whole_ui"),
223	!	style = "margin: 0; padding: 0;",
224	!	uiOutput(ns("active_filter_badge")),
225	!	div(
226	!	id = ns("filter_util_icons"),
227	!	class = "teal-slice filter-util-icons",
228	!	if (allow_add) {
229	!	tags$a(
230	!	class = "teal-slice filter-icon",
231	!	tags$i(
232	!	id = ns("add_filter_icon"),
233	!	class = "fa fa-plus",
234	!	title = "fold/expand transform panel",
235	!	onclick = sprintf(
236	!	"togglePanelItems(this, '%s', 'fa-plus', 'fa-minus');
237	!	if ($(this).hasClass('fa-minus')) {
238	!	$('#%s .accordion-button.collapsed').click();
239		}",
240	!	ns("add_panel"),
241	!	ns("dataset_filter_accordian")
242		)
243		)
244		)
245		},
246	!	uiOutput(ns("remove_filters_ui"))
247		),
248	!	bslib::page_fluid(
249	!	style = "padding: 0px 15px 0px 15px; margin: 0;",
250	!	if (allow_add) {
251	!	tags$div(
252	!	id = ns("add_panel"),
253	!	class = "add-panel",
254	!	style = "display: none;",
255	!	self$ui_add(ns(private$dataname))
256		)
257		}
258		),
259	!	tags$div(
260	!	id = ns("filter_count_ui"),
261	!	style = "display: none;",
262	!	tagList(
263	!	textOutput(ns("filter_count"))
264		)
265		),
266	!	tags$div(
267		# id needed to insert and remove UI to filter single variable as needed
268		# it is currently also used by the above module to entirely hide this panel
269	!	id = ns("filters"),
270	!	class = "parent-hideable-list-group",
271	!	tagList(
272	!	lapply(
273	!	names(private$get_filter_states()),
274	!	function(x) {
275	!	tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x)))
276		}
277		)
278		)
279		)
280		)
281		)
282		),
283	!	tags$script(
284	!	HTML(
285	!	sprintf(
286		"
287	!	$(document).ready(function() {
288	!	$('#%s').appendTo('#%s > .accordion-item > .accordion-header');
289	!	$('#%s > .accordion-item > .accordion-header').css({
290	!	'display': 'flex'
291		});
292	!	$('#%s').appendTo('#%s .accordion-header .accordion-title');
293		});
294		",
295	!	ns("filter_util_icons"),
296	!	ns("dataset_filter_accordian"),
297	!	ns("dataset_filter_accordian"),
298	!	ns("active_filter_badge"),
299	!	ns("dataset_filter_accordian")
300		)
301		)
302		)
303		)
304		},
305
306		#' @description
307		#' Server module for a dataset active filters.
308		#'
309		#' @param id (`character(1)`)
310		#' `shiny` module instance id.
311		#' @return `NULL`.
312		srv_active = function(id) {
313	7x	moduleServer(
314	7x	id = id,
315	7x	function(input, output, session) {
316	7x	dataname <- self$get_dataname()
317	7x	logger::log_debug("FilteredDataset$srv_active initializing, dataname: { dataname }")
318	7x	checkmate::assert_string(dataname)
319
320	7x	filter_count <- reactive({
321	8x	length(self$get_filter_state())
322		})
323
324	7x	output$active_filter_badge <- renderUI({
325	8x	if (filter_count() == 0) {
326	3x	return(NULL)
327		}
328	5x	tags$span(
329	5x	filter_count(),
330	5x	class = "teal-slice data-filter-badge-count"
331		)
332		})
333
334	7x	output$filter_count <- renderText(
335	7x	sprintf(
336	7x	"%d filter%s applied",
337	7x	filter_count(),
338	7x	if (filter_count() != 1) "s" else ""
339		)
340		)
341
342	7x	lapply(
343	7x	names(private$get_filter_states()),
344	7x	function(x) {
345	12x	private$get_filter_states()[[x]]$srv_active(id = x)
346		}
347		)
348
349	7x	is_filter_removable <- reactive({
350	8x	non_anchored <- Filter(function(x) !x$anchored, self$get_filter_state())
351	8x	isTRUE(length(non_anchored) > 0)
352		})
353
354	7x	private$session_bindings[[session$ns("get_filter_state")]] <- observeEvent(
355	7x	self$get_filter_state(),
356	7x	ignoreInit = TRUE,
357		{
358	3x	shinyjs::hide("filter_count_ui")
359	3x	shinyjs::show("filters")
360	3x	shinyjs::toggle("remove_filters_ui", condition = is_filter_removable())
361	3x	shinyjs::runjs(
362	3x	sprintf(
363	3x	"setAndRemoveClass('#%s', 'fa-angle-down', 'fa-angle-right')",
364	3x	session$ns("collapse_icon")
365		)
366		)
367		}
368		)
369
370	7x	output$remove_filters_ui <- renderUI({
371	8x	req(is_filter_removable())
372	5x	tags$div(
373	5x	style = "display: flex;",
374	5x	actionLink(
375	5x	session$ns("remove_filters"),
376	5x	label = "",
377	5x	icon = icon("far fa-circle-xmark"),
378	5x	class = "teal-slice filter-icon"
379		)
380		)
381		})
382
383		# If the accordion input is `NULL` it is being collapsed.
384		# It has the accordion panel label if it is expanded.
385	7x	observeEvent(input$dataset_filter_accordian, ignoreNULL = FALSE, {
386	5x	if (is.null(input$dataset_filter_accordian)) {
387		# Hiding the `add_panel` dropdown and changing the minus icon to plus
388		# TODO: simplify this implementation. This is done in multiple places
389	5x	shinyjs::runjs(
390	5x	sprintf(
391	5x	"var element = $('#%s.fa-minus');
392	5x	if (element.length) {
393	5x	element.click();
394	5x	$('#%s').hide();
395		}",
396	5x	session$ns("add_filter_icon"),
397	5x	session$ns("add_panel")
398		)
399		)
400		}
401		})
402
403	7x	private$session_bindings[[session$ns("remove_filters")]] <- observeEvent(input$remove_filters, {
404	1x	logger::log_debug("FilteredDataset$srv_active@1 removing all non-anchored filters, dataname: { dataname }")
405	1x	self$clear_filter_states()
406		})
407
408	7x	private$session_bindings[[session$ns("inputs")]] <- list(
409	7x	destroy = function() {
410	8x	lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
411		}
412		)
413
414	7x	self$srv_add(private$dataname)
415
416	7x	NULL
417		}
418		)
419		},
420
421		#' @description
422		#' UI module to add filter variable for this dataset.
423		#'
424		#' @param id (`character(1)`)
425		#' `shiny` module instance id.
426		#'
427		#' @return Virtual method, returns nothing and raises error.
428		ui_add = function(id) {
429	1x	stop("Pure virtual method")
430		},
431
432		#' @description
433		#' Server module to add filter variable for this dataset.
434		#' For this class `srv_add` calls multiple modules
435		#' of the same name from `FilterStates` as `MAEFilteredDataset`
436		#' contains one `FilterStates` object for `colData` and one for each experiment.
437		#'
438		#' @param id (`character(1)`)
439		#' `shiny` module instance id.
440		#'
441		#' @return `NULL`.
442		srv_add = function(id) {
443	7x	moduleServer(
444	7x	id = id,
445	7x	function(input, output, session) {
446	7x	logger::log_debug("FilteredDataset$srv_add initializing, dataname: { private$dataname }")
447	7x	elems <- private$get_filter_states()
448	7x	elem_names <- names(private$get_filter_states())
449	7x	lapply(
450	7x	elem_names,
451	7x	function(elem_name) elems[[elem_name]]$srv_add(elem_name)
452		)
453
454	7x	NULL
455		}
456		)
457		},
458
459		#' @description
460		#' Object and dependencies cleanup.
461		#'
462		#' - Destroy inputs and observers stored in `private$session_bindings`
463		#' - Finalize `FilterStates` stored in `private$filter_states`
464		#'
465		#' @return `NULL`, invisibly.
466		finalize = function() {
467	244x	.finalize_session_bindings(self, private)
468	244x	lapply(private$filter_states, function(x) x$finalize())
469	244x	invisible(NULL)
470		}
471		),
472		# private fields ----
473		private = list(
474		dataset = NULL, # data.frame or MultiAssayExperiment
475		data_filtered = NULL,
476		data_filtered_fun = NULL, # function
477		filter_states = list(),
478		dataname = character(0),
479		keys = character(0),
480		label = character(0),
481		session_bindings = list(),
482
483		# Adds `FilterStates` to the `private$filter_states`.
484		# `FilterStates` is added once for each element of the dataset.
485		# @param filter_states (`FilterStates`)
486		# @param id (`character(1)`)
487		add_filter_states = function(filter_states, id) {
488	209x	checkmate::assert_class(filter_states, "FilterStates")
489	209x	checkmate::assert_string(id)
490	209x	x <- stats::setNames(list(filter_states), id)
491	209x	private$filter_states <- c(private$get_filter_states(), x)
492		},
493
494		# @description
495		# Gets `FilterStates` objects in this `FilteredDataset`.
496		# @return list of `FilterStates` objects.
497		get_filter_states = function() {
498	626x	private$filter_states
499		}
500		)
501		)

1		#' Complete filter specification
2		#'
3		#' Create `teal_slices` object to package multiple filters and additional settings.
4		#' Check out [`teal_slices-utilities`] functions for working with `teal_slices` object.
5		#'
6		#' `teal_slices()` collates multiple `teal_slice` objects into a `teal_slices` object,
7		#' a complete filter specification. This is used by all classes above `FilterState`
8		#' as well as `filter_panel_api` wrapper functions.
9		#' `teal_slices` has attributes that modify the behavior of the filter panel, which are resolved by different classes.
10		#'
11		#' `include_varnames` and `exclude_varnames` determine which variables can have filters assigned.
12		#' The former enumerates allowed variables, the latter enumerates forbidden values.
13		#' Since these could be mutually exclusive, it is impossible to set both allowed and forbidden
14		#' variables for one data set in one `teal_slices`.
15		#'
16		#' @param ... any number of `teal_slice` objects.
17		#' @param include_varnames,exclude_varnames (`named list`s of `character`) where list names
18		#' match names of data sets and vector elements match variable names in respective data sets;
19		#' specify which variables are allowed to be filtered; see `Details`.
20		#' @param count_type `r lifecycle::badge("experimental")`
21		#' _This is a new feature. Do kindly share your opinions on
22		#' [`teal.slice`'s GitHub repository](https://github.com/insightsengineering/teal.slice/)._
23		#'
24		#' (`character(1)`) string specifying how observations are tallied by these filter states.
25		#' Possible options:
26		#' - `"none"` (default) to have counts of single `FilterState` to show unfiltered number only.
27		#' - `"all"` to have counts of single `FilterState` to show number of observation in filtered
28		#' and unfiltered dataset. Note, that issues were reported when using this option with `MultiAssayExperiment`.
29		#' Please make sure that adding new filters doesn't fail on target platform before deploying for production.
30		#' @param allow_add (`logical(1)`) logical flag specifying whether the user will be able to add new filters
31		#'
32		#' @return
33		#' `teal_slices`, which is an unnamed list of `teal_slice` objects.
34		#'
35		#' @examples
36		#' filter_1 <- teal_slice(
37		#' dataname = "dataname1",
38		#' varname = "varname1",
39		#' choices = letters,
40		#' selected = "b",
41		#' keep_na = TRUE,
42		#' fixed = FALSE,
43		#' extra1 = "extraone"
44		#' )
45		#' filter_2 <- teal_slice(
46		#' dataname = "dataname1",
47		#' varname = "varname2",
48		#' choices = 1:10,
49		#' keep_na = TRUE,
50		#' selected = 2,
51		#' fixed = TRUE,
52		#' anchored = FALSE,
53		#' extra2 = "extratwo"
54		#' )
55		#' filter_3 <- teal_slice(
56		#' dataname = "dataname2",
57		#' varname = "varname3",
58		#' choices = 1:10 / 10,
59		#' keep_na = TRUE,
60		#' selected = 0.2,
61		#' fixed = TRUE,
62		#' anchored = FALSE,
63		#' extra1 = "extraone",
64		#' extra2 = "extratwo"
65		#' )
66		#'
67		#' all_filters <- teal_slices(
68		#' filter_1,
69		#' filter_2,
70		#' filter_3,
71		#' exclude_varnames = list(
72		#' "dataname1" = "varname2"
73		#' )
74		#' )
75		#'
76		#' is.teal_slices(all_filters)
77		#' all_filters[1:2]
78		#' c(all_filters[1], all_filters[2])
79		#' print(all_filters)
80		#' print(all_filters, trim_lines = FALSE)
81		#'
82		#' @seealso
83		#' - [`teal_slice`] for creating constituent elements of `teal_slices`
84		#' - `teal::slices_store` for robust utilities for saving and loading `teal_slices` in `JSON` format
85		#' - [`is.teal_slices`], [`as.teal_slices`], [`as.list.teal_slices`], [`[.teal_slices`], [`c.teal_slices`]
86		#' [`print.teal_slices`], [`format.teal_slices`]
87		#'
88		#' @export
89		#'
90		teal_slices <- function(...,
91		exclude_varnames = NULL,
92		include_varnames = NULL,
93		count_type = NULL,
94		allow_add = TRUE) {
95	664x	slices <- list(...)
96	664x	checkmate::assert_list(slices, types = "teal_slice", any.missing = FALSE)
97	663x	slices_id <- isolate(vapply(slices, `[[`, character(1L), "id"))
98	663x	if (any(duplicated(slices_id))) {
99	1x	stop(
100	1x	"Some teal_slice objects have the same id:\n",
101	1x	toString(unique(slices_id[duplicated(slices_id)]))
102		)
103		}
104	662x	checkmate::assert_list(exclude_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)
105	661x	checkmate::assert_list(include_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)
106	660x	checkmate::assert_character(count_type, len = 1, null.ok = TRUE)
107	658x	checkmate::assert_subset(count_type, choices = c("all", "none"), empty.ok = TRUE)
108	657x	checkmate::assert_logical(allow_add)
109
110	656x	duplicated_datasets <- intersect(names(include_varnames), names(exclude_varnames))
111	656x	if (length(duplicated_datasets)) {
112	1x	stop(
113	1x	"Some datasets are specified in both, include_varnames and exclude_varnames:\n",
114	1x	toString(duplicated_datasets)
115		)
116		}
117
118	655x	structure(
119	655x	slices,
120	655x	exclude_varnames = exclude_varnames,
121	655x	include_varnames = include_varnames,
122	655x	count_type = count_type,
123	655x	allow_add = allow_add,
124	655x	class = c("teal_slices", class(slices))
125		)
126		}
127
128		#' `teal_slices` utility functions
129		#'
130		#' Helper functions for working with [`teal_slices`] object.
131		#' @param x object to test for `teal_slices`, object to convert to `teal_slices` or a `teal_slices` object
132		#' @param i (`character` or `numeric` or `logical`) indicating which elements to extract
133		#' @param recursive (`logical(1)`) flag specifying whether to also convert to list the elements of this `teal_slices`
134		#' @param ... additional arguments passed to other functions.
135		#' @name teal_slices-utilities
136		#' @inherit teal_slices examples
137		#' @keywords internal
138
139		#' @rdname teal_slices-utilities
140		#' @export
141		#'
142		is.teal_slices <- function(x) { # nolint
143	373x	inherits(x, "teal_slices")
144		}
145
146		#' @rdname teal_slices-utilities
147		#' @export
148		#'
149		as.teal_slices <- function(x) { # nolint
150	!	checkmate::assert_list(x)
151	!	lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")
152
153	!	attrs <- attributes(unclass(x))
154	!	ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))
155	!	do.call(teal_slices, c(ans, attrs))
156		}
157
158
159		#' @rdname teal_slices-utilities
160		#' @export
161		#'
162		as.list.teal_slices <- function(x, recursive = FALSE, ...) { # nolint
163	1047x	ans <- unclass(x)
164	46x	if (recursive) ans[] <- lapply(ans, as.list)
165	1047x	ans
166		}
167
168
169		#' @rdname teal_slices-utilities
170		#' @export
171		#'
172		`[.teal_slices` <- function(x, i) {
173	3x	if (missing(i)) i <- seq_along(x)
174	475x	if (length(i) == 0L) {
175	162x	return(x[0])
176		}
177	1x	if (is.logical(i) && length(i) > length(x)) stop("subscript out of bounds")
178	1x	if (is.numeric(i) && max(i) > length(x)) stop("subscript out of bounds")
179	311x	if (is.character(i)) {
180	1x	if (!all(is.element(i, names(x)))) stop("subscript out of bounds")
181	2x	i <- which(is.element(i, names(x)))
182		}
183
184	310x	y <- NextMethod("[")
185	310x	attrs <- attributes(x)
186	310x	attrs$names <- attrs$names[i]
187	310x	attributes(y) <- attrs
188	310x	y
189		}
190
191
192		#' @rdname teal_slices-utilities
193		#' @export
194		#'
195		c.teal_slices <- function(...) {
196	211x	x <- list(...)
197	211x	checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")
198
199	210x	all_attributes <- lapply(x, attributes)
200	210x	all_attributes <- coalesce_r(all_attributes)
201	210x	all_attributes <- all_attributes[names(all_attributes) != "class"]
202
203	210x	do.call(
204	210x	teal_slices,
205	210x	c(
206	210x	unique(unlist(x, recursive = FALSE)),
207	210x	all_attributes
208		)
209		)
210		}
211
212
213		#' @rdname teal_slices-utilities
214		#' @param show_all (`logical(1)`) whether to display non-null elements of constituent `teal_slice` objects
215		#' @param trim_lines (`logical(1)`) whether to trim lines
216		#' @export
217		#'
218		format.teal_slices <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
219	46x	checkmate::assert_flag(show_all)
220	46x	checkmate::assert_flag(trim_lines)
221
222	46x	x <- as.list(x, recursive = TRUE)
223	46x	attrs <- attributes(x)
224	46x	attributes(x) <- NULL
225	46x	slices_list <- list(slices = x, attributes = attrs)
226	46x	slices_list <- Filter(Negate(is.null), slices_list) # drop attributes if empty
227
228	21x	if (!show_all) slices_list$slices <- lapply(slices_list$slices, function(slice) Filter(Negate(is.null), slice))
229
230	46x	jsonify(slices_list, trim_lines)
231		}
232
233		#' @rdname teal_slices-utilities
234		#' @export
235		#'
236		print.teal_slices <- function(x, ...) {
237	3x	cat(format(x, ...), "\n")
238	3x	invisible(x)
239		}
240
241
242		#' `setdiff` method for `teal_slices`
243		#'
244		#' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`.
245		#' @param x,y (`teal_slices`)
246		#' @return `teal_slices`
247		#' @keywords internal
248		#'
249		setdiff_teal_slices <- function(x, y) {
250	14x	Filter(
251	14x	function(xx) {
252	12x	!any(vapply(y, function(yy) identical(yy, xx), logical(1)))
253		},
254	14x	x
255		)
256		}
257
258		#' Recursively coalesce list elements.
259		#'
260		#' Returns first element of list that it not `NULL`, recursively.
261		#'
262		#' Given a list of atomic vectors, the first non-null element is returned.
263		#' Given a list of lists, for all `names` found in all elements of the list
264		#' the first non-null element of a given name is returned.
265		#'
266		#' This function is used internally in `c.teal_slices` to manage `teal_slices` attributes.
267		#'
268		#' @param x (`list`), either of atomic vectors or of named lists
269		#' @return
270		#' Either an atomic vector of length 1 or a (potentially nested) list.
271		#'
272		#' @keywords internal
273		#'
274		coalesce_r <- function(x) {
275	1312x	checkmate::assert_list(x)
276	1311x	xnn <- Filter(Negate(is.null), x)
277	1311x	if (all(vapply(xnn, is.atomic, logical(1L)))) {
278	884x	return(xnn[[1L]])
279		}
280	427x	lapply(x, checkmate::assert_list, names = "named", null.ok = TRUE, .var.name = "list element")
281	426x	all_names <- unique(unlist(lapply(x, names)))
282	426x	sapply(all_names, function(nm) coalesce_r(lapply(x, `[[`, nm)), simplify = FALSE)
283		}

1		# DatetimeFilterState ------
2
3		#' @rdname DatetimeFilterState
4		#' @docType class
5		#'
6		#' @title `FilterState` object for date time data
7		#'
8		#' @description Manages choosing a range of date-times.
9		#'
10		#' @examples
11		#' # use non-exported function from teal.slice
12		#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
13		#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
14		#' DatetimeFilterState <- getFromNamespace("DatetimeFilterState", "teal.slice")
15		#'
16		#' library(shiny)
17		#'
18		#' filter_state <- DatetimeFilterState$new(
19		#' x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA),
20		#' slice = teal_slice(varname = "x", dataname = "data"),
21		#' extract_type = character(0)
22		#' )
23		#' isolate(filter_state$get_call())
24		#' filter_state$set_state(
25		#' teal_slice(
26		#' dataname = "data",
27		#' varname = "x",
28		#' selected = c(Sys.time() + 3L, Sys.time() + 8L),
29		#' keep_na = TRUE
30		#' )
31		#' )
32		#' isolate(filter_state$get_call())
33		#'
34		#' # working filter in an app
35		#' library(shinyjs)
36		#'
37		#' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00"))
38		#' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA)
39		#' fs <- DatetimeFilterState$new(
40		#' x = data_datetime,
41		#' slice = teal_slice(
42		#' varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE
43		#' )
44		#' )
45		#'
46		#' ui <- fluidPage(
47		#' useShinyjs(),
48		#' include_css_files(pattern = "filter-panel"),
49		#' include_js_files(pattern = "count-bar-labels"),
50		#' column(4, tags$div(
51		#' tags$h4("DatetimeFilterState"),
52		#' fs$ui("fs")
53		#' )),
54		#' column(4, tags$div(
55		#' id = "outputs", # div id is needed for toggling the element
56		#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
57		#' textOutput("condition_datetime"), tags$br(),
58		#' tags$h4("Unformatted state"), # display raw filter state
59		#' textOutput("unformatted_datetime"), tags$br(),
60		#' tags$h4("Formatted state"), # display human readable filter state
61		#' textOutput("formatted_datetime"), tags$br()
62		#' )),
63		#' column(4, tags$div(
64		#' tags$h4("Programmatic filter control"),
65		#' actionButton("button1_datetime", "set drop NA", width = "100%"), tags$br(),
66		#' actionButton("button2_datetime", "set keep NA", width = "100%"), tags$br(),
67		#' actionButton("button3_datetime", "set a range", width = "100%"), tags$br(),
68		#' actionButton("button4_datetime", "set full range", width = "100%"), tags$br(),
69		#' actionButton("button0_datetime", "set initial state", width = "100%"), tags$br()
70		#' ))
71		#' )
72		#'
73		#' server <- function(input, output, session) {
74		#' fs$server("fs")
75		#' output$condition_datetime <- renderPrint(fs$get_call())
76		#' output$formatted_datetime <- renderText(fs$format())
77		#' output$unformatted_datetime <- renderPrint(fs$get_state())
78		#' # modify filter state programmatically
79		#' observeEvent(
80		#' input$button1_datetime,
81		#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
82		#' )
83		#' observeEvent(
84		#' input$button2_datetime,
85		#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
86		#' )
87		#' observeEvent(
88		#' input$button3_datetime,
89		#' fs$set_state(
90		#' teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)])
91		#' )
92		#' )
93		#' observeEvent(
94		#' input$button4_datetime,
95		#' fs$set_state(
96		#' teal_slice(dataname = "data", varname = "x", selected = datetimes)
97		#' )
98		#' )
99		#' observeEvent(
100		#' input$button0_datetime,
101		#' fs$set_state(
102		#' teal_slice(
103		#' dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE
104		#' )
105		#' )
106		#' )
107		#' }
108		#'
109		#' if (interactive()) {
110		#' shinyApp(ui, server)
111		#' }
112		#'
113		#' @keywords internal
114		#'
115		DatetimeFilterState <- R6::R6Class( # nolint
116		"DatetimeFilterState",
117		inherit = FilterState,
118
119		# public methods ----
120
121		public = list(
122
123		#' @description
124		#' Initialize a `FilterState` object. This class
125		#' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by
126		#' default. However, in case when using this module in `teal` app, one needs
127		#' timezone of the app user. App user timezone is taken from `session$userData$timezone`
128		#' and is set only if object is initialized in `shiny`.
129		#'
130		#' @param x (`POSIXct` or `POSIXlt`)
131		#' variable to be filtered.
132		#' @param x_reactive (`reactive`)
133		#' returning vector of the same type as `x`. Is used to update
134		#' counts following the change in values of the filtered dataset.
135		#' If it is set to `reactive(NULL)` then counts based on filtered
136		#' dataset are not shown.
137		#' @param slice (`teal_slice`)
138		#' specification of this filter state.
139		#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
140		#' `get_state` returns `teal_slice` object which can be reused in other places.
141		#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
142		#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
143		#' @param extract_type (`character`)
144		#' specifying whether condition calls should be prefixed by `dataname`. Possible values:
145		#' - `character(0)` (default) `varname` in the condition call will not be prefixed
146		#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
147		#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
148		#'
149		#' @return Object of class `DatetimeFilterState`, invisibly.
150		#'
151		initialize = function(x,
152		x_reactive = reactive(NULL),
153		extract_type = character(0),
154		slice) {
155	25x	isolate({
156	25x	checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
157	24x	checkmate::assert_class(x_reactive, "reactive")
158
159	24x	super$initialize(
160	24x	x = x,
161	24x	x_reactive = x_reactive,
162	24x	slice = slice,
163	24x	extract_type = extract_type
164		)
165	24x	checkmate::assert_multi_class(slice$choices, c("POSIXct", "POSIXlt"), null.ok = TRUE)
166	23x	private$set_choices(slice$choices)
167	15x	if (is.null(slice$selected)) slice$selected <- slice$choices
168	23x	private$set_selected(slice$selected)
169		})
170
171	22x	invisible(self)
172		},
173
174		#' @description
175		#' Returns reproducible condition call for current selection.
176		#' For this class returned call looks like
177		#' `<varname> >= as.POSIXct(<min>) & <varname> <= <max>)` with optional `is.na(<varname>)`.
178		#' @param dataname name of data set; defaults to `private$get_dataname()`
179		#' @return `call`
180		#'
181		get_call = function(dataname) {
182	7x	if (isFALSE(private$is_any_filtered())) {
183	1x	return(NULL)
184		}
185	4x	if (missing(dataname)) dataname <- private$get_dataname()
186	6x	varname <- private$get_varname_prefixed(dataname)
187	6x	choices <- private$get_selected()
188	6x	tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone"))
189	6x	class <- class(choices)[1L]
190	6x	date_fun <- as.name(
191	6x	switch(class,
192	6x	"POSIXct" = "as.POSIXct",
193	6x	"POSIXlt" = "as.POSIXlt"
194		)
195		)
196	6x	choices <- as.character(choices + c(0, 1))
197	6x	filter_call <-
198	6x	call(
199		"&",
200	6x	call(
201		">=",
202	6x	varname,
203	6x	as.call(list(date_fun, choices[1L], tz = tzone))
204		),
205	6x	call(
206		"<",
207	6x	varname,
208	6x	as.call(list(date_fun, choices[2L], tz = tzone))
209		)
210		)
211	6x	private$add_keep_na_call(filter_call, varname)
212		}
213		),
214
215		# private members ----
216
217		private = list(
218		# private methods ----
219		set_choices = function(choices) {
220	23x	if (is.null(choices)) {
221	20x	choices <- as.POSIXct(trunc(range(private$x, na.rm = TRUE), units = "secs"))
222		} else {
223	3x	choices <- as.POSIXct(choices, units = "secs")
224	3x	choices_adjusted <- c(
225	3x	max(choices[1L], min(as.POSIXct(private$x), na.rm = TRUE)),
226	3x	min(choices[2L], max(as.POSIXct(private$x), na.rm = TRUE))
227		)
228	3x	if (any(choices != choices_adjusted)) {
229	1x	warning(sprintf(
230	1x	"Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",
231	1x	private$get_varname(), private$get_dataname()
232		))
233	1x	choices <- choices_adjusted
234		}
235	3x	if (choices[1L] >= choices[2L]) {
236	1x	warning(sprintf(
237	1x	"Invalid choices: lower is higher / equal to upper, or not in range of variable values.
238	1x	Setting defaults. Varname: %s, dataname: %s.",
239	1x	private$get_varname(), private$get_dataname()
240		))
241	1x	choices <- range(private$x, na.rm = TRUE)
242		}
243		}
244
245	23x	private$set_is_choice_limited(private$x, choices)
246	23x	private$x <- private$x[
247		(
248	23x	as.POSIXct(trunc(private$x, units = "secs")) >= choices[1L] &
249	23x	as.POSIXct(trunc(private$x, units = "secs")) <= choices[2L]
250	23x	) \| is.na(private$x)
251		]
252	23x	private$teal_slice$choices <- choices
253	23x	invisible(NULL)
254		},
255
256		# @description
257		# Check whether the initial choices filter out some values of x and set the flag in case.
258		set_is_choice_limited = function(xl, choices = NULL) {
259	23x	private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) \| any(xl > choices[2L], na.rm = TRUE))
260	23x	invisible(NULL)
261		},
262		cast_and_validate = function(values) {
263	34x	tryCatch(
264	34x	expr = {
265	34x	values <- as.POSIXct(values, origin = "1970-01-01 00:00:00")
266	!	if (anyNA(values)) stop()
267	31x	values
268		},
269	34x	error = function(e) stop("Vector of set values must contain values coercible to POSIX.")
270		)
271		},
272		check_length = function(values) {
273	1x	if (length(values) != 2) stop("Vector of set values must have length two.")
274	30x	if (values[1] > values[2]) {
275	1x	warning(
276	1x	sprintf(
277	1x	"Start date '%s' is set after the end date '%s', the values will be replaced by a default datetime range.",
278	1x	values[1], values[2]
279		)
280		)
281	1x	values <- isolate(private$get_choices())
282		}
283	30x	values
284		},
285		remove_out_of_bounds_values = function(values) {
286	30x	choices <- private$get_choices()
287	30x	if (values[1] < choices[1L] \|\| values[1] > choices[2L]) {
288	5x	warning(
289	5x	sprintf(
290	5x	"Value: %s is outside of the range for the column '%s' in dataset '%s', setting minimum possible value.",
291	5x	values[1], private$get_varname(), toString(private$get_dataname())
292		)
293		)
294	5x	values[1] <- choices[1L]
295		}
296
297	30x	if (values[2] > choices[2L] \| values[2] < choices[1L]) {
298	5x	warning(
299	5x	sprintf(
300	5x	"Value: '%s' is outside of the range for the column '%s' in dataset '%s', setting maximum possible value.",
301	5x	values[2], private$get_varname(), toString(private$get_dataname())
302		)
303		)
304	5x	values[2] <- choices[2L]
305		}
306
307	30x	values
308		},
309
310		# shiny modules ----
311
312		# @description
313		# UI Module for `DatetimeFilterState`.
314		# This UI element contains two date-time selections for `min` and `max`
315		# of the range and a checkbox whether to keep the `NA` values.
316		# @param id (`character(1)`) `shiny` module instance id.
317		ui_inputs = function(id) {
318	!	ns <- NS(id)
319
320	!	isolate({
321	!	ui_input_1 <- shinyWidgets::airDatepickerInput(
322	!	inputId = ns("selection_start"),
323	!	value = private$get_selected()[1],
324	!	startView = private$get_selected()[1],
325	!	timepicker = TRUE,
326	!	minDate = private$get_choices()[1L],
327	!	maxDate = private$get_choices()[2L],
328	!	update_on = "close",
329	!	addon = "none",
330	!	position = "bottom right"
331		)
332	!	ui_input_2 <- shinyWidgets::airDatepickerInput(
333	!	inputId = ns("selection_end"),
334	!	value = private$get_selected()[2],
335	!	startView = private$get_selected()[2],
336	!	timepicker = TRUE,
337	!	minDate = private$get_choices()[1L],
338	!	maxDate = private$get_choices()[2L],
339	!	update_on = "close",
340	!	addon = "none",
341	!	position = "bottom right"
342		)
343	!	ui_reset_1 <- actionButton(
344	!	class = "date_reset_button",
345	!	inputId = ns("start_date_reset"),
346	!	label = NULL,
347	!	icon = icon("fas fa-undo")
348		)
349	!	ui_reset_2 <- actionButton(
350	!	class = "date_reset_button",
351	!	inputId = ns("end_date_reset"),
352	!	label = NULL,
353	!	icon = icon("fas fa-undo")
354		)
355	!	ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm"))
356	!	ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm"))
357
358	!	tags$div(
359	!	tags$div(
360	!	class = "flex",
361	!	ui_reset_1,
362	!	tags$div(
363	!	class = "flex w-80 filter_datelike_input",
364	!	tags$div(class = "w-45 text-center", ui_input_1),
365	!	tags$span(
366	!	class = "input-group-addon w-10",
367	!	tags$span(class = "input-group-text w-100 justify-content-center", "to"),
368	!	title = "Times are displayed in the local timezone and are converted to UTC in the analysis"
369		),
370	!	tags$div(class = "w-45 text-center", ui_input_2)
371		),
372	!	ui_reset_2
373		),
374	!	private$keep_na_ui(ns("keep_na"))
375		)
376		})
377		},
378
379		# @description
380		# Server module
381		# @param id (`character(1)`) `shiny` module instance id.
382		# @return `NULL`.
383		server_inputs = function(id) {
384	!	moduleServer(
385	!	id = id,
386	!	function(input, output, session) {
387	!	logger::log_debug("DatetimeFilterState$server initializing, id: { private$get_id() }")
388		# this observer is needed in the situation when teal_slice$selected has been
389		# changed directly by the api - then it's needed to rerender UI element
390		# to show relevant values
391	!	private$session_bindings[[session$ns("selection_api")]] <- observeEvent(
392	!	ignoreNULL = TRUE, # dates needs to be selected
393	!	ignoreInit = TRUE, # on init selected == default, so no need to trigger
394	!	eventExpr = private$get_selected(),
395	!	handlerExpr = {
396	!	start_date <- input$selection_start
397	!	end_date <- input$selection_end
398	!	if (!all(private$get_selected() == c(start_date, end_date))) {
399	!	logger::log_debug("DatetimeFilterState$server@1 state changed, id: { private$get_id() }")
400	!	if (private$get_selected()[1] != start_date) {
401	!	shinyWidgets::updateAirDateInput(
402	!	session = session,
403	!	inputId = "selection_start",
404	!	value = private$get_selected()[1]
405		)
406		}
407
408	!	if (private$get_selected()[2] != end_date) {
409	!	shinyWidgets::updateAirDateInput(
410	!	session = session,
411	!	inputId = "selection_end",
412	!	value = private$get_selected()[2]
413		)
414		}
415		}
416		}
417		)
418
419
420	!	private$session_bindings[[session$ns("selection_start")]] <- observeEvent(
421	!	ignoreNULL = TRUE, # dates needs to be selected
422	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
423	!	eventExpr = input$selection_start,
424	!	handlerExpr = {
425	!	logger::log_debug("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
426	!	start_date <- input$selection_start
427	!	end_date <- private$get_selected()[[2]]
428	!	tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))
429	!	attr(start_date, "tzone") <- tzone
430
431	!	if (start_date > end_date) {
432	!	showNotification(
433	!	"Start date must not be greater than the end date. Ignoring selection.",
434	!	type = "warning"
435		)
436	!	shinyWidgets::updateAirDateInput(
437	!	session = session,
438	!	inputId = "selection_start",
439	!	value = private$get_selected()[1] # sets back to latest selected value
440		)
441	!	return(NULL)
442		}
443
444	!	private$set_selected(c(start_date, end_date))
445		}
446		)
447
448	!	private$session_bindings[[session$ns("selection_end")]] <- observeEvent(
449	!	ignoreNULL = TRUE, # dates needs to be selected
450	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
451	!	eventExpr = input$selection_end,
452	!	handlerExpr = {
453	!	start_date <- private$get_selected()[1]
454	!	end_date <- input$selection_end
455	!	tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))
456	!	attr(end_date, "tzone") <- tzone
457
458	!	if (start_date > end_date) {
459	!	showNotification(
460	!	"End date must not be lower than the start date. Ignoring selection.",
461	!	type = "warning"
462		)
463	!	shinyWidgets::updateAirDateInput(
464	!	session = session,
465	!	inputId = "selection_end",
466	!	value = private$get_selected()[2] # sets back to latest selected value
467		)
468	!	return(NULL)
469		}
470
471	!	private$set_selected(c(start_date, end_date))
472	!	logger::log_debug("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
473		}
474		)
475
476	!	private$keep_na_srv("keep_na")
477
478	!	private$session_bindings[[session$ns("reset1")]] <- observeEvent(
479	!	ignoreInit = TRUE, # reset button shouldn't be trigger on init
480	!	ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL
481	!	input$start_date_reset,
482		{
483	!	shinyWidgets::updateAirDateInput(
484	!	session = session,
485	!	inputId = "selection_start",
486	!	value = private$get_choices()[1L]
487		)
488	!	logger::log_debug("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
489		}
490		)
491	!	private$session_bindings[[session$ns("reset2")]] <- observeEvent(
492	!	ignoreInit = TRUE, # reset button shouldn't be trigger on init
493	!	ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL
494	!	input$end_date_reset,
495		{
496	!	shinyWidgets::updateAirDateInput(
497	!	session = session,
498	!	inputId = "selection_end",
499	!	value = private$get_choices()[2L]
500		)
501	!	logger::log_debug("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
502		}
503		)
504
505	!	NULL
506		}
507		)
508		},
509		server_inputs_fixed = function(id) {
510	!	moduleServer(
511	!	id = id,
512	!	function(input, output, session) {
513	!	logger::log_debug("DatetimeFilterState$server initializing, id: { private$get_id() }")
514
515	!	output$selection <- renderUI({
516	!	vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3)
517	!	tags$div(
518	!	tags$div(icon("clock"), vals[1]),
519	!	tags$div(span(" - "), icon("clock"), vals[2])
520		)
521		})
522
523	!	NULL
524		}
525		)
526		},
527
528		# @description
529		# UI module to display filter summary
530		# renders text describing selected date range and
531		# if NA are included also
532		content_summary = function(id) {
533	!	selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S")
534	!	min <- selected[1]
535	!	max <- selected[2]
536	!	tagList(
537	!	tags$span(
538	!	class = "filter-card-summary-value",
539	!	HTML(min, "–", max)
540		),
541	!	tags$span(
542	!	class = "filter-card-summary-controls",
543	!	if (private$na_count > 0) {
544	!	tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
545		}
546		)
547		)
548		}
549		)
550		)

1		#' Initialize `FilterState`
2		#'
3		#' Initializes a `FilterState` object corresponding to the class of the filtered variable.
4		#'
5		#' @param x (`vector`)
6		#' variable to be filtered.
7		#' @param x_reactive (`reactive`)
8		#' returning vector of the same type as `x`. Is used to update
9		#' counts following the change in values of the filtered dataset.
10		#' If it is set to `reactive(NULL)` then counts based on filtered
11		#' dataset are not shown.
12		#' @param slice (`teal_slice`)
13		#' specification of this filter state.
14		#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
15		#' `get_state` returns `teal_slice` object which can be reused in other places.
16		#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
17		#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
18		#' @param extract_type (`character`)
19		#' specifying whether condition calls should be prefixed by `dataname`. Possible values:
20		#' - `character(0)` (default) `varname` in the condition call will not be prefixed
21		#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
22		#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
23		#'
24		#' @examples
25		#' # use non-exported function from teal.slice
26		#' init_filter_state <- getFromNamespace("init_filter_state", "teal.slice")
27		#'
28		#' library(shiny)
29		#'
30		#' filter_state <- init_filter_state(
31		#' x = c(1:10, NA, Inf),
32		#' x_reactive = reactive(c(1:10, NA, Inf)),
33		#' slice = teal_slice(
34		#' varname = "varname",
35		#' dataname = "dataname"
36		#' ),
37		#' extract_type = "matrix"
38		#' )
39		#'
40		#' isolate(filter_state$get_call())
41		#'
42		#' # working filter in an app
43		#'
44		#' ui <- fluidPage(
45		#' filter_state$ui(id = "app"),
46		#' verbatimTextOutput("call")
47		#' )
48		#' server <- function(input, output, session) {
49		#' filter_state$server("app")
50		#'
51		#' output$call <- renderText(
52		#' deparse1(filter_state$get_call(), collapse = "\n")
53		#' )
54		#' }
55		#'
56		#' if (interactive()) {
57		#' shinyApp(ui, server)
58		#' }
59		#'
60		#' @return `FilterState` object
61		#' @keywords internal
62		init_filter_state <- function(x,
63		x_reactive = reactive(NULL),
64		slice,
65		extract_type = character(0)) {
66	187x	checkmate::assert_class(x_reactive, "reactive")
67	186x	checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)
68	186x	checkmate::assert_class(slice, "teal_slice")
69	185x	if (length(extract_type) == 1) {
70	40x	checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
71		}
72
73	184x	if (all(is.na(x))) {
74	1x	EmptyFilterState$new(
75	1x	x = x,
76	1x	x_reactive = x_reactive,
77	1x	slice = slice,
78	1x	extract_type = extract_type
79		)
80		} else {
81	183x	UseMethod("init_filter_state")
82		}
83		}
84
85		#' @keywords internal
86		#' @export
87		init_filter_state.default <- function(x,
88		x_reactive = reactive(NULL),
89		slice,
90		extract_type = character(0)) {
91	1x	args <- list(
92	1x	x = x,
93	1x	x_reactive = x_reactive,
94	1x	extract_type = extract_type,
95	1x	slice
96		)
97
98	1x	do.call(FilterState$new, args)
99		}
100
101		#' @keywords internal
102		#' @export
103		init_filter_state.logical <- function(x,
104		x_reactive = reactive(NULL),
105		slice,
106		extract_type = character(0)) {
107	1x	LogicalFilterState$new(
108	1x	x = x,
109	1x	x_reactive = x_reactive,
110	1x	slice = slice,
111	1x	extract_type = extract_type
112		)
113		}
114
115		#' @keywords internal
116		#' @export
117		init_filter_state.numeric <- function(x,
118		x_reactive = reactive(NULL),
119		slice,
120		extract_type = character(0)) {
121	115x	args <- list(
122	115x	x = x,
123	115x	x_reactive = x_reactive,
124	115x	slice = slice,
125	115x	extract_type = extract_type
126		)
127
128	115x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
129	26x	do.call(ChoicesFilterState$new, args)
130		} else {
131	89x	do.call(RangeFilterState$new, args)
132		}
133		}
134
135		#' @keywords internal
136		#' @export
137		init_filter_state.factor <- function(x,
138		x_reactive = reactive(NULL),
139		slice,
140		extract_type = character(0)) {
141	30x	ChoicesFilterState$new(
142	30x	x = x,
143	30x	x_reactive = x_reactive,
144	30x	slice = slice,
145	30x	extract_type = extract_type
146		)
147		}
148
149		#' @keywords internal
150		#' @export
151		init_filter_state.character <- function(x,
152		x_reactive = reactive(NULL),
153		slice,
154		extract_type = character(0)) {
155	30x	ChoicesFilterState$new(
156	30x	x = x,
157	30x	x_reactive = x_reactive,
158	30x	slice = slice,
159	30x	extract_type = extract_type
160		)
161		}
162
163		#' @keywords internal
164		#' @export
165		init_filter_state.Date <- function(x,
166		x_reactive = reactive(NULL),
167		slice,
168		extract_type = character(0)) {
169	2x	args <- list(
170	2x	x = x,
171	2x	x_reactive = x_reactive,
172	2x	slice = slice,
173	2x	extract_type = extract_type
174		)
175
176	2x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
177	1x	do.call(ChoicesFilterState$new, args)
178		} else {
179	1x	do.call(DateFilterState$new, args)
180		}
181		}
182
183		#' @keywords internal
184		#' @export
185		init_filter_state.POSIXct <- function(x,
186		x_reactive = reactive(NULL),
187		slice,
188		extract_type = character(0)) {
189	2x	args <- list(
190	2x	x = x,
191	2x	x_reactive = x_reactive,
192	2x	slice = slice,
193	2x	extract_type = extract_type
194		)
195
196	2x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
197	1x	do.call(ChoicesFilterState$new, args)
198		} else {
199	1x	do.call(DatetimeFilterState$new, args)
200		}
201		}
202
203		#' @keywords internal
204		#' @export
205		init_filter_state.POSIXlt <- function(x,
206		x_reactive = reactive(NULL),
207		slice,
208		extract_type = character(0)) {
209	2x	args <- list(
210	2x	x = x,
211	2x	x_reactive = x_reactive,
212	2x	slice = slice,
213	2x	extract_type = extract_type
214		)
215
216	2x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
217	1x	do.call(ChoicesFilterState$new, args)
218		} else {
219	1x	do.call(DatetimeFilterState$new, args)
220		}
221		}
222
223
224		#' Initialize a `FilterStateExpr` object
225		#'
226		#' @param slice (`teal_slice_expr`)
227		#' specifying this filter state.
228		#'
229		#' @return `FilterStateExpr` object
230		#' @keywords internal
231		init_filter_state_expr <- function(slice) {
232	6x	FilterStateExpr$new(slice)
233		}
234
235
236		#' Get hex code of the current Bootstrap theme color.
237		#'
238		#' Determines the color specification for the currently active Bootstrap color theme and returns one queried color.
239		#'
240		#' @param color (`character(1)`) naming one of the available theme colors
241		#' @param alpha either a `numeric(1)` or `character(1)` specifying transparency
242		#' in the range of `0-1` or a hexadecimal value `00-ff`, respectively;
243		#' set to NULL to omit adding the alpha channel
244		#'
245		#' @return Named `character(1)` containing a hexadecimal color representation.
246		#'
247		#' @examples
248		#' fetch_bs_color <- getFromNamespace("fetch_bs_color", "teal.slice")
249		#' fetch_bs_color("primary")
250		#' fetch_bs_color("danger", 0.35)
251		#' fetch_bs_color("danger", "80")
252		#'
253		#' @keywords internal
254		#'
255		fetch_bs_color <- function(color, alpha = NULL) {
256	116x	checkmate::assert_string(color)
257	116x	checkmate::assert(
258	116x	checkmate::check_number(alpha, lower = 0, upper = 1, null.ok = TRUE),
259	116x	checkmate::check_string(alpha, pattern = "[0-9a-f]{2}", null.ok = TRUE)
260		)
261
262		# locate file that describes the current theme
263	116x	sass_file <- if (utils::packageVersion("bslib") < as.package_version("0.5.1.9000")) {
264	!	bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]]
265		} else {
266	116x	bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]][[1]]
267		}
268	116x	sass_file <- attr(sass_file, "sass_file_path")
269
270		# load scss file that encodes variables
271	116x	variables_file <- readLines(sass_file)
272		# locate theme color variables
273	116x	ind <- grep("// scss-docs-(start\|end) theme-color-variables", variables_file)
274	116x	color_definitions <- variables_file[(ind[1] + 1L):(ind[2] - 1L)]
275
276		# extract colors names
277	116x	color_names <- sub("(\\$)(\\w.+)(:.+)", "\\2", color_definitions)
278
279		# verify that an available color was requested
280	116x	checkmate::assert_choice(color, color_names)
281
282		# extract color references
283	116x	color_references <- sub("(\\$)(\\w.+)(:\\s.+\\$)(\\w.+)(\\s.+)", "\\4", color_definitions)
284
285		# translate references to color codes
286	116x	color_specification <- structure(color_references, names = color_names)
287	116x	color_specification <- vapply(color_specification, function(x) {
288	928x	line <- grep(sprintf("^\\$%s:\\s+#\\w{6}\\s+!default", x), variables_file, value = TRUE)
289	928x	code <- sub("(.+)(#\\w{6})(\\s+.+)", "\\2", line)
290	928x	code
291	116x	}, character(1L))
292
293	116x	if (!is.null(alpha)) {
294	!	if (is.numeric(alpha)) alpha <- as.hexmode(ceiling(255 * alpha))
295		}
296
297	116x	paste0(color_specification[color], alpha)
298		}

1		#' Specify single filter
2		#'
3		#' Create a `teal_slice` object that holds complete information on filtering one variable.
4		#' Check out [`teal_slice-utilities`] functions for working with `teal_slice` object.
5		#'
6		#' `teal_slice` object fully describes filter state and can be used to create,
7		#' modify, and delete a filter state. A `teal_slice` contains a number of common fields
8		#' (all named arguments of `teal_slice`), some of which are mandatory, but only
9		#' `dataname` and either `varname` or `expr` must be specified, while the others have default
10		#' values.
11		#'
12		#' Setting any of the other values to `NULL` means that those properties will not be modified
13		#' (when setting an existing state) or that they will be determined by data (when creating new a new one).
14		#' Entire object is `FilterState` class member and can be accessed with `FilterState$get_state()`.
15		#'
16		#' A `teal_slice` can come in two flavors:
17		#' 1. `teal_slice_var` -
18		#' this describes a typical interactive filter that refers to a single variable, managed by the `FilterState` class.
19		#' This class is created when `varname` is specified.
20		#' The object retains all fields specified in the call. `id` can be created by default and need not be specified.
21		#' 2. `teal_slice_expr` -
22		#' this describes a filter state that refers to an expression, which can potentially include multiple variables,
23		#' managed by the `FilterStateExpr` class.
24		#' This class is created when `expr` is specified.
25		#' `dataname` and `anchored` are retained, `fixed` is set to `TRUE`, `id` becomes mandatory, `title`
26		#' remains optional, while other arguments are disregarded.
27		#'
28		#' A teal_slice can be passed `FilterState`/`FilterStateExpr` constructors to instantiate an object.
29		#' It can also be passed to `FilterState$set_state` to modify the state.
30		#' However, once a `FilterState` is created, only the mutable features can be set with a teal_slice:
31		#' `selected`, `keep_na` and `keep_inf`.
32		#'
33		#' Special consideration is given to two fields: `fixed` and `anchored`.
34		#' These are always immutable logical flags that default to `FALSE`.
35		#' In a `FilterState` instantiated with `fixed = TRUE` the features
36		#' `selected`, `keep_na`, `keep_inf` cannot be changed.
37		#' Note that a `FilterStateExpr` is always considered to have `fixed = TRUE`.
38		#' A `FilterState` instantiated with `anchored = TRUE` cannot be removed.
39		#'
40		#' @section Filters in `SumarizedExperiment` and `MultiAssayExperiment` objects:
41		#'
42		#' To establish a filter on a column in a `data.frame`, `dataname` and `varname` are sufficient.
43		#' `MultiAssayExperiment` objects can be filtered either on their `colData` slot (which contains subject information)
44		#' or on their experiments, which are stored in the `experimentList` slot.
45		#' For filters referring to `colData` no extra arguments are needed.
46		#' If a filter state is created for an experiment, that experiment name must be specified in the `experiment` argument.
47		#' Furthermore, to specify filter for an `SummarizedExperiment` one must also set `arg`
48		#' (`"subset"` or `"select"`, arguments in the [subset()] function for `SummarizedExperiment`)
49		#' in order to determine whether the filter refers to the `SE`'s `rowData` or `colData`.
50		#'
51		#' @param dataname (`character(1)`) name of data set
52		#' @param varname (`character(1)`) name of variable
53		#' @param id (`character(1)`) identifier of the filter. Must be specified when `expr` is set.
54		#' When `varname` is specified then `id` is set to `"{dataname} {varname}"` by default.
55		#' @param expr (`character(1)`) string providing a logical expression.
56		#' Must be a valid `R` expression which can be evaluated in the context of the data set.
57		#' For a `data.frame` `var == "x"` is sufficient, but `MultiAssayExperiment::subsetByColData`
58		#' requires `dataname` prefix, e.g. `data$var == "x"`.
59		#' @param choices (`vector`) optional, specifies allowed choices;
60		#' When specified it should be a subset of values in variable denoted by `varname`;
61		#' Type and size depends on variable type. Factors are coerced to character.
62		#' @param selected (`vector`) optional, specifies selected values from `choices`;
63		#' Type and size depends on variable type. Factors are coerced to character.
64		#' @param multiple (`logical(1)`) optional flag specifying whether more than one value can be selected;
65		#' only applicable to `ChoicesFilterState` and `LogicalFilterState`
66		#' @param keep_na (`logical(1)`) optional flag specifying whether to keep missing values
67		#' @param keep_inf (`logical(1)`) optional flag specifying whether to keep infinite values
68		#' @param fixed (`logical(1)`) flag specifying whether to fix this filter state (forbid setting state)
69		#' @param anchored (`logical(1)`) flag specifying whether to lock this filter state (forbid removing and inactivating)
70		#' @param title (`character(1)`) optional title of the filter. Ignored when `varname` is set.
71		#' @param ... additional arguments which can be handled by extensions of `teal.slice` classes.
72		#'
73		#' @return A `teal.slice` object. Depending on whether `varname` or `expr` was specified, the resulting
74		#' `teal_slice` also receives class `teal_slice_var` or `teal_slice_expr`, respectively.
75		#'
76		#' @note Date time objects of `POSIX*t` classes are printed as strings after converting to UTC timezone.
77		#'
78		#' @examples
79		#' x1 <- teal_slice(
80		#' dataname = "data",
81		#' id = "Female adults",
82		#' expr = "SEX == 'F' & AGE >= 18",
83		#' title = "Female adults"
84		#' )
85		#' x2 <- teal_slice(
86		#' dataname = "data",
87		#' varname = "var",
88		#' choices = c("F", "M", "U"),
89		#' selected = "F",
90		#' keep_na = TRUE,
91		#' keep_inf = TRUE,
92		#' fixed = FALSE,
93		#' anchored = FALSE,
94		#' multiple = TRUE,
95		#' id = "Gender",
96		#' extra_arg = "extra"
97		#' )
98		#'
99		#' is.teal_slice(x1)
100		#' as.list(x1)
101		#' as.teal_slice(list(dataname = "a", varname = "var"))
102		#' format(x1)
103		#' format(x1, show_all = TRUE, trim_lines = FALSE)
104		#' print(x1)
105		#' print(x1, show_all = TRUE, trim_lines = FALSE)
106		#'
107		#' @seealso [`teal_slices`],
108		#' [`is.teal_slice`], [`as.teal_slice`], [`as.list.teal_slice`], [`print.teal_slice`], [`format.teal_slice`]
109		#'
110		#' @export
111		teal_slice <- function(dataname,
112		varname,
113		id,
114		expr,
115		choices = NULL,
116		selected = NULL,
117		keep_na = NULL,
118		keep_inf = NULL,
119		fixed = FALSE,
120		anchored = FALSE,
121		multiple = TRUE,
122		title = NULL,
123		...) {
124	578x	checkmate::assert_string(dataname)
125	571x	checkmate::assert_flag(fixed)
126	569x	checkmate::assert_flag(anchored)
127
128	567x	formal_args <- as.list(environment())
129
130	567x	if (!missing(expr) && !missing(varname)) {
131	!	stop("Must provide either `expr` or `varname`.")
132	567x	} else if (!missing(expr)) {
133	30x	checkmate::assert_string(id)
134	27x	checkmate::assert_string(title)
135	24x	checkmate::assert_string(expr)
136
137	23x	formal_args$fixed <- TRUE
138	23x	ts_expr_args <- c("dataname", "id", "expr", "fixed", "anchored", "title")
139	23x	formal_args <- formal_args[ts_expr_args]
140	23x	ans <- do.call(reactiveValues, c(formal_args, list(...)))
141	23x	class(ans) <- c("teal_slice_expr", "teal_slice", class(ans))
142	537x	} else if (!missing(varname)) {
143	536x	checkmate::assert_string(varname)
144	533x	checkmate::assert_multi_class(choices, .filterable_class, null.ok = TRUE)
145	532x	checkmate::assert_multi_class(selected, .filterable_class, null.ok = TRUE)
146	530x	checkmate::assert_flag(keep_na, null.ok = TRUE)
147	529x	checkmate::assert_flag(keep_inf, null.ok = TRUE)
148	528x	checkmate::assert_flag(multiple)
149
150	528x	ts_var_args <- c(
151	528x	"dataname", "varname", "id", "choices", "selected", "keep_na", "keep_inf",
152	528x	"fixed", "anchored", "multiple"
153		)
154	528x	formal_args <- formal_args[ts_var_args]
155	528x	args <- c(formal_args, list(...))
156	528x	args[c("choices", "selected")] <-
157	528x	lapply(args[c("choices", "selected")], function(x) if (is.factor(x)) as.character(x) else x)
158	528x	if (missing(id)) {
159	519x	args$id <- get_default_slice_id(args)
160		} else {
161	9x	checkmate::assert_string(id)
162		}
163	525x	ans <- do.call(reactiveValues, args)
164	525x	class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
165		} else {
166	1x	stop("Must provide either `expr` or `varname`.")
167		}
168
169	548x	ans
170		}
171
172		#' `teal_slice` utility functions
173		#'
174		#' Helper functions for working with [`teal_slice`] object.
175		#' @param x (`teal.slice`)
176		#' @param show_all (`logical(1)`) indicating whether to show all fields. If set to `FALSE`,
177		#' only non-NULL elements will be printed.
178		#' @param trim_lines (`logical(1)`) indicating whether to trim lines when printing.
179		#' @param ... additional arguments passed to other functions.
180		#' @name teal_slice-utilities
181		#' @inherit teal_slice examples
182		#' @keywords internal
183
184		#' @rdname teal_slice-utilities
185		#' @export
186		#'
187		is.teal_slice <- function(x) { # nolint
188	4x	inherits(x, "teal_slice")
189		}
190
191		#' @rdname teal_slice-utilities
192		#' @export
193		#'
194		as.teal_slice <- function(x) { # nolint
195	!	checkmate::assert_list(x, names = "named")
196	!	do.call(teal_slice, x)
197		}
198
199		#' @rdname teal_slice-utilities
200		#' @export
201		#'
202		as.list.teal_slice <- function(x, ...) {
203	286x	formal_args <- setdiff(names(formals(teal_slice)), "...")
204
205	286x	x <- if (isRunning()) {
206	!	reactiveValuesToList(x)
207		} else {
208	286x	isolate(reactiveValuesToList(x))
209		}
210
211	286x	formal_args <- intersect(formal_args, names(x))
212	286x	extra_args <- rev(setdiff(names(x), formal_args))
213
214	286x	x[c(formal_args, extra_args)]
215		}
216
217
218		#' @rdname teal_slice-utilities
219		#' @export
220		#'
221		format.teal_slice <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
222	117x	checkmate::assert_flag(show_all)
223	93x	checkmate::assert_flag(trim_lines)
224
225	87x	x_list <- as.list(x)
226	48x	if (!show_all) x_list <- Filter(Negate(is.null), x_list)
227
228	87x	jsonify(x_list, trim_lines)
229		}
230
231		#' @rdname teal_slice-utilities
232		#' @export
233		#'
234		print.teal_slice <- function(x, ...) {
235	16x	cat(format(x, ...))
236	16x	invisible(x)
237		}
238
239
240		# format utils -----
241
242		#' Convert a list to a justified `JSON` string
243		#'
244		#' This function takes a list and converts it to a `JSON` string.
245		#' The resulting `JSON` string is then optionally justified to improve readability
246		#' and trimmed to easier fit in the console when printing.
247		#'
248		#' @param x (`list`), possibly recursive, obtained from `teal_slice` or `teal_slices`.
249		#' @param trim_lines (`logical(1)`) flag specifying whether to trim lines of the `JSON` string.
250		#' @return A `JSON` string representation of the input list.
251		#' @keywords internal
252		#'
253		jsonify <- function(x, trim_lines) {
254	133x	checkmate::assert_list(x)
255
256	133x	x_json <- to_json(x)
257	133x	x_json_justified <- justify_json(x_json)
258	123x	if (trim_lines) x_json_justified <- trim_lines_json(x_json_justified)
259	133x	paste(x_json_justified, collapse = "\n")
260		}
261
262		#' Converts a list to a `JSON` string
263		#'
264		#' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string.
265		#' Ensures proper unboxing of list elements.
266		#' This function is used by the `format` methods for `teal_slice` and `teal_slices`.
267		#' @param x (`list`) possibly recursive, obtained from `teal_slice` or `teal_slices`.
268		#' @return A `JSON` string.
269		#
270		#' @param x (`list`) representation of `teal_slices` object.
271		#' @keywords internal
272		#'
273		to_json <- function(x) {
274	133x	no_unbox <- function(x) {
275	2415x	vars <- c("selected", "choices")
276	2415x	if (is.list(x)) {
277	391x	for (var in vars) {
278	307x	if (!is.null(x[[var]])) x[[var]] <- I(format_time(x[[var]]))
279		}
280	391x	lapply(x, no_unbox)
281		} else {
282	2024x	x
283		}
284		}
285
286	133x	jsonlite::toJSON(no_unbox(x), pretty = TRUE, auto_unbox = TRUE, digits = 16, null = "null")
287		}
288
289		#' Format `POSIXt` for storage
290		#'
291		#' Convert `POSIXt` date time object to character representation in UTC time zone.
292		#'
293		#' Date times are stored as string representations expressed in the UTC time zone.
294		#' The storage format is `YYYY-MM-DD HH:MM:SS`.
295		#'
296		#' @param x (`POSIXt`) vector of date time values or anything else
297		#'
298		#' @return If `x` is of class `POSIXt`, a character vector, otherwise `x` itself.
299		#'
300		#' @keywords internal
301		format_time <- function(x) {
302	307x	if ("POSIXt" %in% class(x)) {
303	20x	format(x, format = "%Y-%m-%d %H:%M:%S", usetz = TRUE, tz = "UTC")
304		} else {
305	287x	x
306		}
307		}
308
309		#' Justify colons in `JSON` string
310		#'
311		#' This function takes a `JSON` string as input, splits it into lines, and pads element names
312		#' with spaces so that colons are justified between lines.
313		#'
314		#' @param json (`character(1)`) a `JSON` string.
315		#'
316		#' @return A list of character strings, which can be collapsed into a `JSON` string.
317		#'
318		#' @keywords internal
319		justify_json <- function(json) {
320	133x	format_name <- function(name, name_width) {
321	2806x	if (nchar(name) == 1 \|\| nchar(gsub("\\s", "", name)) <= 2) {
322	640x	return(name)
323	2166x	} else if (grepl("slices\|attributes", name)) {
324	92x	paste0(name, ":")
325		} else {
326	2074x	paste(format(name, width = name_width), ":")
327		}
328		}
329	133x	json_lines <- strsplit(json, "\n")[[1]]
330	133x	json_lines_split <- regmatches(json_lines, regexpr(":", json_lines), invert = TRUE)
331	133x	name_width <- max(unlist(regexpr(":", json_lines))) - 1
332	133x	vapply(json_lines_split, function(x) paste0(format_name(x[1], name_width), stats::na.omit(x[2])), character(1))
333		}
334
335		#' Trim lines in `JSON` string
336		#'
337		#' This function takes a `JSON` string as input and returns a modified version of the
338		#' input where the values portion of each line is trimmed for a less messy console output.
339		#'
340		#' @param x (`character`)
341		#'
342		#' @return A character string trimmed after a certain hard-coded number of characters in the value portion.
343		#'
344		#' @keywords internal
345		#'
346		trim_lines_json <- function(x) {
347	123x	name_width <- max(unlist(gregexpr(":", x))) - 1
348	123x	trim_position <- name_width + 37L
349	123x	x_trim <- substr(x, 1, trim_position)
350	123x	substr(x_trim, trim_position - 2, trim_position) <- "..."
351	123x	x_trim
352		}
353
354		#' Default `teal_slice` id
355		#'
356		#' Create a slice id if none provided.
357		#'
358		#' Function returns a default `id` for a `teal_slice` object which needs
359		#' to be distinct from other `teal_slice` objects created for any
360		#' `FilterStates` object. Returned `id` can be treated as a location of
361		#' a vector on which `FilterState` is built:
362		#' - for a `data.frame` `id` concatenates `dataname` and `varname`.
363		#' - for a `MultiAssayExperiment` `id` concatenates `dataname`, `varname`,
364		#' `experiment` and `arg`, so that one can add `teal_slice` for a `varname`
365		#' which exists in multiple `SummarizedExperiment`s or exists in both `colData`
366		#' and `rowData` of given experiment.
367		#' For such a vector `teal.slice` doesn't allow to activate more than one filters.
368		#' In case of `teal_slice_expr` `id` is mandatory and must be unique.
369		#'
370		#' @param x (`teal_slice` or `list`)
371		#' @return (`character(1)`) `id` for a `teal_slice` object.
372		#'
373		#' @keywords internal
374		get_default_slice_id <- function(x) {
375	608x	checkmate::assert_multi_class(x, c("teal_slice", "list"))
376	608x	isolate({
377	608x	if (inherits(x, "teal_slice_expr") \|\| is.null(x$varname)) {
378	10x	x$id
379		} else {
380	598x	paste(
381	598x	Filter(
382	598x	length,
383	598x	as.list(x)[c("dataname", "varname", "experiment", "arg")]
384		),
385	598x	collapse = " "
386		)
387		}
388		})
389		}

1		# LogicalFilterState ------
2
3		#' @name LogicalFilterState
4		#' @docType class
5		#'
6		#' @title `FilterState` object for logical data
7		#'
8		#' @description Manages choosing a logical state.
9		#'
10		#' @examples
11		#' # use non-exported function from teal.slice
12		#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
13		#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
14		#' LogicalFilterState <- getFromNamespace("LogicalFilterState", "teal.slice")
15		#'
16		#' library(shiny)
17		#'
18		#' filter_state <- LogicalFilterState$new(
19		#' x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE),
20		#' slice = teal_slice(varname = "x", dataname = "data")
21		#' )
22		#' isolate(filter_state$get_call())
23		#' filter_state$set_state(
24		#' teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE)
25		#' )
26		#' isolate(filter_state$get_call())
27		#'
28		#' # working filter in an app
29		#' library(shinyjs)
30		#'
31		#' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA)
32		#' fs <- LogicalFilterState$new(
33		#' x = data_logical,
34		#' slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)
35		#' )
36		#'
37		#' ui <- fluidPage(
38		#' useShinyjs(),
39		#' include_css_files(pattern = "filter-panel"),
40		#' include_js_files(pattern = "count-bar-labels"),
41		#' column(4, tags$div(
42		#' tags$h4("LogicalFilterState"),
43		#' fs$ui("fs")
44		#' )),
45		#' column(4, tags$div(
46		#' id = "outputs", # div id is needed for toggling the element
47		#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
48		#' textOutput("condition_logical"), tags$br(),
49		#' tags$h4("Unformatted state"), # display raw filter state
50		#' textOutput("unformatted_logical"), tags$br(),
51		#' tags$h4("Formatted state"), # display human readable filter state
52		#' textOutput("formatted_logical"), tags$br()
53		#' )),
54		#' column(4, tags$div(
55		#' tags$h4("Programmatic filter control"),
56		#' actionButton("button1_logical", "set drop NA", width = "100%"), tags$br(),
57		#' actionButton("button2_logical", "set keep NA", width = "100%"), tags$br(),
58		#' actionButton("button3_logical", "set a selection", width = "100%"), tags$br(),
59		#' actionButton("button0_logical", "set initial state", width = "100%"), tags$br()
60		#' ))
61		#' )
62		#'
63		#' server <- function(input, output, session) {
64		#' fs$server("fs")
65		#' output$condition_logical <- renderPrint(fs$get_call())
66		#' output$formatted_logical <- renderText(fs$format())
67		#' output$unformatted_logical <- renderPrint(fs$get_state())
68		#' # modify filter state programmatically
69		#' observeEvent(
70		#' input$button1_logical,
71		#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
72		#' )
73		#' observeEvent(
74		#' input$button2_logical,
75		#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
76		#' )
77		#' observeEvent(
78		#' input$button3_logical,
79		#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE))
80		#' )
81		#' observeEvent(
82		#' input$button0_logical,
83		#' fs$set_state(
84		#' teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)
85		#' )
86		#' )
87		#' }
88		#'
89		#' if (interactive()) {
90		#' shinyApp(ui, server)
91		#' }
92		#'
93		#' @keywords internal
94		#'
95		LogicalFilterState <- R6::R6Class( # nolint
96		"LogicalFilterState",
97		inherit = FilterState,
98
99		# public methods ----
100		public = list(
101
102		#' @description
103		#' Initialize a `FilterState` object.
104		#'
105		#' @param x (`logical`)
106		#' variable to be filtered.
107		#' @param x_reactive (`reactive`)
108		#' returning vector of the same type as `x`. Is used to update
109		#' counts following the change in values of the filtered dataset.
110		#' If it is set to `reactive(NULL)` then counts based on filtered
111		#' dataset are not shown.
112		#' @param slice (`teal_slice`)
113		#' specification of this filter state.
114		#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
115		#' `get_state` returns `teal_slice` object which can be reused in other places.
116		#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
117		#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
118		#' @param extract_type (`character`)
119		#' specifying whether condition calls should be prefixed by `dataname`. Possible values:
120		#' - `character(0)` (default) `varname` in the condition call will not be prefixed
121		#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
122		#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
123		#'
124		#' @return Object of class `LogicalFilterState`, invisibly.
125		#'
126		initialize = function(x,
127		x_reactive = reactive(NULL),
128		extract_type = character(0),
129		slice) {
130	16x	isolate({
131	16x	checkmate::assert_logical(x)
132	15x	checkmate::assert_logical(slice$selected, null.ok = TRUE)
133	14x	super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type)
134
135	14x	private$set_choices(slice$choices)
136	!	if (is.null(slice$multiple)) slice$multiple <- FALSE
137	14x	if (is.null(slice$selected) && slice$multiple) {
138	7x	slice$selected <- private$get_choices()
139	7x	} else if (length(slice$selected) != 1 && !slice$multiple) {
140	3x	slice$selected <- TRUE
141		}
142	14x	private$set_selected(slice$selected)
143	14x	df <- factor(x, levels = c(TRUE, FALSE))
144	14x	tbl <- table(df)
145	14x	private$set_choices_counts(tbl)
146		})
147	14x	invisible(self)
148		},
149
150		#' @description
151		#' Returns reproducible condition call for current selection.
152		#' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally `is.na(<varname>)`
153		#' @param dataname name of data set; defaults to `private$get_dataname()`
154		#' @return `call`
155		#'
156		get_call = function(dataname) {
157	6x	if (isFALSE(private$is_any_filtered())) {
158	!	return(NULL)
159		}
160	4x	if (missing(dataname)) dataname <- private$get_dataname()
161	6x	varname <- private$get_varname_prefixed(dataname)
162	6x	choices <- private$get_selected()
163	6x	n_choices <- length(choices)
164
165	6x	filter_call <-
166	6x	if (n_choices == 1 && choices) {
167	1x	varname
168	6x	} else if (n_choices == 1 && !choices) {
169	4x	call("!", varname)
170		} else {
171	1x	call("%in%", varname, make_c_call(choices))
172		}
173	6x	private$add_keep_na_call(filter_call, varname)
174		}
175		),
176
177		# private members ----
178		private = list(
179		choices_counts = integer(0),
180
181		# private methods ----
182		set_choices = function(choices) {
183	14x	private$teal_slice$choices <- c(TRUE, FALSE)
184	14x	invisible(NULL)
185		},
186		# @description
187		# Sets choices_counts private field
188		set_choices_counts = function(choices_counts) {
189	14x	private$choices_counts <- choices_counts
190	14x	invisible(NULL)
191		},
192		cast_and_validate = function(values) {
193	21x	tryCatch(
194	21x	expr = {
195	21x	values <- as.logical(values)
196	1x	if (anyNA(values)) stop()
197	20x	values
198		},
199	21x	error = function(e) stop("Vector of set values must contain values coercible to logical.")
200		)
201		},
202		# If multiple forbidden but selected, restores previous selection with warning.
203		check_length = function(values) {
204	20x	if (!private$is_multiple() && length(values) > 1) {
205	1x	warning(
206	1x	sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
207	1x	"Maintaining previous selection."
208		)
209	1x	values <- isolate(private$get_selected())
210		}
211	20x	values
212		},
213
214		# Answers the question of whether the current settings and values selected actually filters out any values.
215		# @return logical scalar
216		is_any_filtered = function() {
217	6x	if (private$is_choice_limited) {
218	!	TRUE
219	6x	} else if (all(private$choices_counts > 0)) {
220	6x	TRUE
221		} else if (
222	!	setequal(private$get_selected(), private$get_choices()) &&
223	!	!anyNA(private$get_selected(), private$get_choices())
224		) {
225	!	TRUE
226	!	} else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
227	!	TRUE
228		} else {
229	!	FALSE
230		}
231		},
232
233		# shiny modules ----
234
235		# @description
236		# UI Module for `EmptyFilterState`.
237		# This UI element contains available choices selection and
238		# checkbox whether to keep or not keep the `NA` values.
239		# @param id (`character(1)`) `shiny` module instance id.
240		ui_inputs = function(id) {
241	!	ns <- NS(id)
242	!	isolate({
243	!	countsmax <- private$choices_counts
244	!	countsnow <- if (!is.null(private$x_reactive())) {
245	!	unname(table(factor(private$x_reactive(), levels = private$get_choices())))
246		} else {
247	!	NULL
248		}
249
250	!	labels <- countBars(
251	!	inputId = ns("labels"),
252	!	choices = as.character(private$get_choices()),
253	!	countsnow = countsnow,
254	!	countsmax = countsmax
255		)
256	!	ui_input <- if (private$is_multiple()) {
257	!	checkboxGroupInput(
258	!	inputId = ns("selection"),
259	!	label = NULL,
260	!	selected = isolate(as.character(private$get_selected())),
261	!	choiceNames = labels,
262	!	choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
263	!	width = "100%"
264		)
265		} else {
266	!	radioButtons(
267	!	inputId = ns("selection"),
268	!	label = NULL,
269	!	selected = isolate(as.character(private$get_selected())),
270	!	choiceNames = labels,
271	!	choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
272	!	width = "100%"
273		)
274		}
275	!	tags$div(
276	!	tags$div(
277	!	class = "choices_state",
278	!	uiOutput(ns("trigger_visible"), inline = TRUE),
279	!	ui_input
280		),
281	!	private$keep_na_ui(ns("keep_na"))
282		)
283		})
284		},
285
286		# @description
287		# Server module
288		# @param id (`character(1)`) `shiny` module instance id.
289		# @return `NULL`.
290		server_inputs = function(id) {
291	!	moduleServer(
292	!	id = id,
293	!	function(input, output, session) {
294		# this observer is needed in the situation when teal_slice$selected has been
295		# changed directly by the api - then it's needed to rerender UI element
296		# to show relevant values
297	!	non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))
298	!	output$trigger_visible <- renderUI({
299	!	logger::log_debug("LogicalFilterState$server@1 updating count labels, id: { private$get_id() }")
300
301	!	countsnow <- if (!is.null(private$x_reactive())) {
302	!	unname(table(factor(non_missing_values(), levels = private$get_choices())))
303		} else {
304	!	NULL
305		}
306
307	!	updateCountBars(
308	!	inputId = "labels",
309	!	choices = as.character(private$get_choices()),
310	!	countsmax = private$choices_counts,
311	!	countsnow = countsnow
312		)
313	!	NULL
314		})
315
316	!	private$session_bindings[[session$ns("selected_api")]] <- observeEvent(
317	!	ignoreNULL = !private$is_multiple(),
318	!	ignoreInit = TRUE,
319	!	eventExpr = private$get_selected(),
320	!	handlerExpr = {
321	!	if (!setequal(private$get_selected(), input$selection)) {
322	!	logger::log_debug("LogicalFilterState$server@1 state changed, id: { private$get_id() }")
323	!	if (private$is_multiple()) {
324	!	updateCheckboxGroupInput(
325	!	inputId = "selection",
326	!	selected = private$get_selected()
327		)
328		} else {
329	!	updateRadioButtons(
330	!	inputId = "selection",
331	!	selected = private$get_selected()
332		)
333		}
334		}
335		}
336		)
337
338	!	private$session_bindings[[session$ns("selection")]] <- observeEvent(
339	!	ignoreNULL = FALSE,
340	!	ignoreInit = TRUE,
341	!	eventExpr = input$selection,
342	!	handlerExpr = {
343	!	logger::log_debug("LogicalFilterState$server@2 selection changed, id: { private$get_id() }")
344		# for private$is_multiple() == TRUE input$selection will always have value
345	!	if (is.null(input$selection) && isFALSE(private$is_multiple())) {
346	!	selection_state <- private$get_selected()
347		} else {
348	!	selection_state <- as.logical(input$selection)
349		}
350
351	!	if (is.null(selection_state)) {
352	!	selection_state <- logical(0)
353		}
354	!	private$set_selected(selection_state)
355		}
356		)
357
358	!	private$keep_na_srv("keep_na")
359
360	!	NULL
361		}
362		)
363		},
364		server_inputs_fixed = function(id) {
365	!	moduleServer(
366	!	id = id,
367	!	function(input, output, session) {
368	!	logger::log_debug("LogicalFilterState$server initializing, id: { private$get_id() }")
369
370	!	output$selection <- renderUI({
371	!	countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices())))
372	!	countsmax <- private$choices_counts
373
374	!	ind <- private$get_choices() %in% private$get_selected()
375	!	countBars(
376	!	inputId = session$ns("labels"),
377	!	choices = private$get_selected(),
378	!	countsnow = countsnow[ind],
379	!	countsmax = countsmax[ind]
380		)
381		})
382
383	!	NULL
384		}
385		)
386		},
387
388		# @description
389		# Server module to display filter summary
390		# renders text describing whether TRUE or FALSE is selected
391		# and if NA are included also
392		content_summary = function(id) {
393	!	tagList(
394	!	tags$span(
395	!	class = "filter-card-summary-value",
396	!	toString(private$get_selected())
397		),
398	!	tags$span(
399	!	class = "filter-card-summary-controls",
400	!	if (private$na_count > 0) {
401	!	tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
402		}
403		)
404		)
405		}
406		)
407		)

1		# DataframeFilteredDataset ------
2
3		#' @name DataframeFilteredDataset
4		#' @docType class
5		#' @title The `DataframeFilteredDataset` `R6` class
6		#'
7		#' @examples
8		#' # use non-exported function from teal.slice
9		#' DataframeFilteredDataset <- getFromNamespace("DataframeFilteredDataset", "teal.slice")
10		#'
11		#' library(shiny)
12		#'
13		#' ds <- DataframeFilteredDataset$new(iris, "iris")
14		#' ds$set_filter_state(
15		#' teal_slices(
16		#' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),
17		#' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))
18		#' )
19		#' )
20		#' isolate(ds$get_filter_state())
21		#' isolate(ds$get_call())
22		#'
23		#' ## set_filter_state
24		#' dataset <- DataframeFilteredDataset$new(iris, "iris")
25		#' fs <- teal_slices(
26		#' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),
27		#' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))
28		#' )
29		#' dataset$set_filter_state(state = fs)
30		#' isolate(dataset$get_filter_state())
31		#'
32		#' @keywords internal
33		#'
34		DataframeFilteredDataset <- R6::R6Class( # nolint
35		classname = "DataframeFilteredDataset",
36		inherit = FilteredDataset,
37
38		# public fields ----
39		public = list(
40
41		#' @description
42		#' Initializes this `DataframeFilteredDataset` object.
43		#'
44		#' @param dataset (`data.frame`)
45		#' single `data.frame` for which filters are rendered.
46		#' @param dataname (`character(1)`)
47		#' syntactically valid name given to the dataset.
48		#' @param keys (`character`) optional
49		#' vector of primary key column names.
50		#' @param parent_name (`character(1)`)
51		#' name of the parent dataset.
52		#' @param parent (`reactive`)
53		#' that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`.
54		#' Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset`
55		#' based on the changes in `parent`.
56		#' @param join_keys (`character`)
57		#' vector of names of columns in this dataset to join with `parent` dataset.
58		#' If column names in the parent do not match these, they should be given as the names of this vector.
59		#' @param label (`character(1)`)
60		#' label to describe the dataset.
61		#'
62		#' @return Object of class `DataframeFilteredDataset`, invisibly.
63		#'
64		initialize = function(dataset,
65		dataname,
66		keys = character(0),
67		parent_name = character(0),
68		parent = NULL,
69		join_keys = character(0),
70		label = character(0)) {
71	99x	checkmate::assert_data_frame(dataset)
72	97x	super$initialize(dataset, dataname, keys, label)
73
74		# overwrite filtered_data if there is relationship with parent dataset
75	95x	if (!is.null(parent)) {
76	10x	checkmate::assert_character(parent_name, len = 1)
77	10x	checkmate::assert_character(join_keys, min.len = 1)
78
79	10x	private$parent_name <- parent_name
80	10x	private$join_keys <- join_keys
81
82	10x	private$data_filtered_fun <- function(sid = "") {
83	8x	checkmate::assert_character(sid)
84	8x	if (length(sid)) {
85	8x	logger::log_debug("filtering data dataname: { dataname }, sid: { sid }")
86		} else {
87	!	logger::log_debug("filtering data dataname: { dataname }")
88		}
89	8x	env <- new.env(parent = parent.env(globalenv()))
90	8x	env[[dataname]] <- private$dataset
91	8x	env[[parent_name]] <- parent()
92	8x	filter_call <- self$get_call(sid)
93	8x	eval_expr_with_msg(filter_call, env)
94	8x	get(x = dataname, envir = env)
95		}
96		}
97
98	95x	private$add_filter_states(
99	95x	filter_states = init_filter_states(
100	95x	data = dataset,
101	95x	data_reactive = private$data_filtered_fun,
102	95x	dataname = dataname,
103	95x	keys = self$get_keys()
104		),
105	95x	id = "filter"
106		)
107
108		# todo: Should we make these defaults? It could be handled by the app developer
109	95x	if (!is.null(parent)) {
110	10x	logger::log_debug("Excluding { parent_name } columns from possible teal_slices for dataname: { dataname }")
111	10x	fs <- teal_slices(
112	10x	exclude_varnames = structure(
113	10x	list(intersect(colnames(dataset), colnames(isolate(parent())))),
114	10x	names = private$dataname
115		)
116		)
117	10x	self$set_filter_state(fs)
118		}
119
120	95x	invisible(self)
121		},
122
123		#' @description
124		#' Gets the subset expression.
125		#'
126		#' This function returns subset expressions equivalent to selected items
127		#' within each of `filter_states`. Configuration of the expressions is constant and
128		#' depends on `filter_states` type and order which are set during initialization.
129		#' This class contains single `FilterStates` which contains single `state_list`
130		#' and all `FilterState` objects apply to one argument (`...`) in a `dplyr::filter` call.
131		#'
132		#' @param sid (`character`)
133		#' when specified, the method returns code containing conditions calls of
134		#' `FilterState` objects with `sid` different to that of this `sid` argument.
135		#'
136		#' @return Either a `list` of length 1 containing a filter `call`, or `NULL`.
137		get_call = function(sid = "") {
138	42x	filter_call <- super$get_call(sid)
139	42x	dataname <- private$dataname
140	42x	parent_dataname <- private$parent_name
141
142	42x	if (!identical(parent_dataname, character(0))) {
143	9x	join_keys <- private$join_keys
144	9x	parent_keys <- unname(join_keys)
145	9x	dataset_keys <- names(join_keys)
146
147	9x	y_arg <- if (length(parent_keys) == 0L) {
148	!	parent_dataname
149		} else {
150	9x	sprintf(
151	9x	"%s[, c(%s), drop = FALSE]",
152	9x	parent_dataname,
153	9x	toString(dQuote(parent_keys, q = FALSE))
154		)
155		}
156
157	9x	more_args <- if (length(parent_keys) == 0 \|\| length(dataset_keys) == 0) {
158	!	list()
159	9x	} else if (identical(parent_keys, dataset_keys)) {
160	7x	list(by = parent_keys)
161		} else {
162	2x	list(by = stats::setNames(parent_keys, dataset_keys))
163		}
164
165	9x	merge_call <- call(
166		"<-",
167	9x	as.name(dataname),
168	9x	as.call(
169	9x	c(
170	9x	str2lang("dplyr::inner_join"),
171	9x	x = as.name(dataname),
172	9x	y = str2lang(y_arg),
173	9x	more_args
174		)
175		)
176		)
177
178	9x	filter_call <- c(filter_call, merge_call)
179		}
180	42x	filter_call
181		},
182
183		#' @description
184		#' Set filter state.
185		#'
186		#' @param state (`teal_slices`)
187		#' @return `NULL`, invisibly.
188		#'
189		set_filter_state = function(state) {
190	77x	isolate({
191	77x	logger::log_debug("FilteredDatasetDataframe$set_filter_state initializing, dataname: { private$dataname }")
192	77x	checkmate::assert_class(state, "teal_slices")
193	76x	state_datanames <- unique(vapply(state, `[[`, character(1L), "dataname"))
194	76x	checkmate::assert_subset(state_datanames, private$dataname)
195	76x	private$get_filter_states()[[1L]]$set_filter_state(state = state)
196	76x	invisible(NULL)
197		})
198		},
199
200		#' @description
201		#' Remove one or more `FilterState` form a `FilteredDataset`.
202		#'
203		#' @param state (`teal_slices`)
204		#' specifying `FilterState` objects to remove;
205		#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored
206		#'
207		#' @return `NULL`, invisibly.
208		#'
209		remove_filter_state = function(state) {
210	11x	checkmate::assert_class(state, "teal_slices")
211
212	11x	isolate({
213	11x	logger::log_debug(
214	11x	"FilteredDatasetDataframe$remove_filter_state removing filter(s), dataname: { private$dataname }"
215		)
216
217	11x	varnames <- unique(unlist(lapply(state, "[[", "varname")))
218	11x	private$get_filter_states()[[1]]$remove_filter_state(state)
219		})
220
221	11x	invisible(NULL)
222		},
223
224		#' @description
225		#' UI module to add filter variable for this dataset.
226		#'
227		#' @param id (`character(1)`)
228		#' `shiny` module instance id.
229		#'
230		#' @return `shiny.tag`
231		ui_add = function(id) {
232	!	ns <- NS(id)
233	!	tagList(
234	!	tags$div(
235	!	tags$label("Add", tags$code(self$get_dataname()), "filter")
236		),
237	!	private$get_filter_states()[["filter"]]$ui_add(id = ns("filter"))
238		)
239		},
240
241		#' @description
242		#' Creates row for filter overview in the form of \cr
243		#' `dataname -- observations (remaining/total)` - data.frame
244		#' @return A `data.frame`.
245		get_filter_overview = function() {
246	12x	logger::log_debug("FilteredDataset$srv_filter_overview initializing for dataname: { private$dataname }")
247		# Gets filter overview subjects number and returns a list
248		# of the number of subjects of filtered/non-filtered datasets
249	12x	subject_keys <- if (length(private$parent_name) > 0) {
250	1x	names(private$join_keys)
251		} else {
252	11x	self$get_keys()
253		}
254	12x	dataset <- self$get_dataset()
255	12x	data_filtered <- self$get_dataset(TRUE)
256	12x	if (length(subject_keys) == 0) {
257	10x	data.frame(
258	10x	dataname = private$dataname,
259	10x	obs = nrow(dataset),
260	10x	obs_filtered = nrow(data_filtered())
261		)
262		} else {
263	2x	data.frame(
264	2x	dataname = private$dataname,
265	2x	obs = nrow(dataset),
266	2x	obs_filtered = nrow(data_filtered()),
267	2x	subjects = nrow(unique(dataset[subject_keys])),
268	2x	subjects_filtered = nrow(unique(data_filtered()[subject_keys]))
269		)
270		}
271		}
272		),
273
274		# private fields ----
275		private = list(
276		parent_name = character(0),
277		join_keys = character(0)
278		)
279		)

1		#' Compose predicates
2		#'
3		#' Combines calls with a logical operator.
4		#'
5		#' This function is used to combine logical predicates produced by `FilterState` objects
6		#' to build a complete subset expression.
7		#'
8		#' @param calls (`list`)
9		#' containing calls (or symbols) to be combined by `operator`
10		#' @param operator (`character(1)`)
11		#' infix operator to use in predicate composition, _e.g._ `"&"`
12		#'
13		#' @return
14		#' A `call` where elements of `calls` are composed with `operator` or `NULL` if `calls` is an empty list.
15		#'
16		#' @examples
17		#' # use non-exported function from teal.slice
18		#' calls_combine_by <- getFromNamespace("calls_combine_by", "teal.slice")
19		#'
20		#' calls <- list(
21		#' quote(SEX == "F"), # subsetting on factor
22		#' quote(AGE >= 20 & AGE <= 50), # subsetting on range
23		#' quote(!SURV) # subsetting on logical
24		#' )
25		#' calls_combine_by(calls, "&")
26		#'
27		#' @keywords internal
28		#'
29		calls_combine_by <- function(calls, operator) {
30	47x	checkmate::assert_list(calls)
31	45x	if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
32	46x	checkmate::assert_string(operator)
33
34	44x	Reduce(
35	44x	x = calls,
36	44x	f = function(x, y) call(operator, x, y)
37		)
38		}

1		.onLoad <- function(libname, pkgname) { # nolint
2		# adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R
3	!	teal_default_options <- list(teal.threshold_slider_vs_checkboxgroup = 5)
4	!	op <- options()
5	!	toset <- !(names(teal_default_options) %in% names(op))
6	!	if (any(toset)) options(teal_default_options[toset])
7
8		# Set up the teal logger instance
9	!	teal.logger::register_logger("teal.slice")
10	!	teal.logger::register_handlers("teal.slice")
11
12	!	invisible()
13		}
14
15		### GLOBAL VARIABLES ###
16
17		.filterable_class <- c("logical", "integer", "numeric", "factor", "character", "Date", "POSIXct", "POSIXlt")
18
19
20		### END GLOBAL VARIABLES ###
21
22
23		### ENSURE CHECK PASSES
24
25		# This function is necessary for check to properly process code dependencies within R6 classes.
26		# If `package` is listed in `Imports` in `DESCRIPTION`,
27		# (1) check goes through `NAMESPACE` looking for any `importFrom(package,<foo>)` statements
28		# or an `import(package)` statement. If none are found,
29		# (2) check looks for `package::*` calls in the code. If none are found again,
30		# (3) check throws a NOTE;
31		# # Namespaces in Imports field not imported from:
32		# # 'package'
33		# # All declared Imports should be used.
34		# This note is banned by our CI.
35		# When package::* statements are made within an R6 class, they are not registered.
36		# This function provides single references to the imported namespaces for check to notice.
37		.rectify_dependencies_check <- function() {
38	!	dplyr::filter
39	!	grDevices::rgb
40	!	htmltools::tagInsertChildren
41	!	lifecycle::badge
42	!	logger::log_debug
43	!	plotly::plot_ly
44	!	shinycssloaders::withSpinner
45	!	shinyWidgets::pickerOptions
46	!	teal.data::datanames
47	!	teal.widgets::optionalSelectInput
48		}
49
50
51		### END ENSURE CHECK PASSES

1		# FilterStateExpr ------
2
3		#' @name FilterStateExpr
4		#' @docType class
5		#'
6		#' @title `FilterStateExpr` `R6` class
7		#'
8		#' @description Sister class to `FilterState` that handles arbitrary filter expressions.
9		#'
10		#' @details
11		#' Creates a filter state around a predefined condition call (logical predicate).
12		#' The condition call is independent of the data
13		#' and the filter card allows no interaction (the filter is always fixed).
14		#'
15		#' @examples
16		#' # use non-exported function from teal.slice
17		#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
18		#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
19		#' FilterStateExpr <- getFromNamespace("FilterStateExpr", "teal.slice")
20		#'
21		#' filter_state <- FilterStateExpr$new(
22		#' slice = teal_slice(
23		#' dataname = "x",
24		#' id = "FA",
25		#' title = "Adult females",
26		#' expr = "sex == 'F' & age >= 18"
27		#' )
28		#' )
29		#' filter_state$get_call()
30		#'
31		#' # working filter in an app
32		#' library(shiny)
33		#' library(shinyjs)
34		#'
35		#' ui <- fluidPage(
36		#' useShinyjs(),
37		#' include_css_files(pattern = "filter-panel"),
38		#' include_js_files(pattern = "count-bar-labels"),
39		#' column(4, tags$div(
40		#' tags$h4("ChoicesFilterState"),
41		#' filter_state$ui("fs")
42		#' )),
43		#' column(8, tags$div(
44		#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
45		#' textOutput("condition_choices"), tags$br(),
46		#' tags$h4("Unformatted state"), # display raw filter state
47		#' textOutput("unformatted_choices"), tags$br(),
48		#' tags$h4("Formatted state"), # display human readable filter state
49		#' textOutput("formatted_choices"), tags$br()
50		#' ))
51		#' )
52		#'
53		#' server <- function(input, output, session) {
54		#' filter_state$server("fs")
55		#' output$condition_choices <- renderPrint(filter_state$get_call())
56		#' output$formatted_choices <- renderText(filter_state$format())
57		#' output$unformatted_choices <- renderPrint(filter_state$get_state())
58		#' }
59		#'
60		#' if (interactive()) {
61		#' shinyApp(ui, server)
62		#' }
63		#'
64		#' @keywords internal
65		#'
66		FilterStateExpr <- R6::R6Class( # nolint
67		classname = "FilterStateExpr",
68		# public methods ----
69		public = list(
70		#' @description
71		#' Initialize a `FilterStateExpr` object.
72		#' @param slice (`teal_slice_expr`)
73		#' @return Object of class `FilterStateExpr`, invisibly.
74		#'
75		initialize = function(slice) {
76	15x	checkmate::assert_class(slice, "teal_slice_expr")
77	14x	private$teal_slice <- slice
78	14x	invisible(self)
79		},
80
81		#' @description
82		#' Returns a formatted string representing this `FilterStateExpr` object.
83		#'
84		#' @param show_all (`logical(1)`) passed to `format.teal_slice`
85		#' @param trim_lines (`logical(1)`) passed to `format.teal_slice`
86		#'
87		#' @return `character(1)` the formatted string
88		#'
89		format = function(show_all = FALSE, trim_lines = TRUE) {
90	12x	sprintf(
91	12x	"%s:\n%s",
92	12x	class(self)[1],
93	12x	format(self$get_state(), show_all = show_all, trim_lines = trim_lines)
94		)
95		},
96
97		#' @description
98		#' Prints this `FilterStateExpr` object.
99		#' @param ... arguments passed to the `format` method
100		#' @return `NULL`, invisibly.
101		#'
102		print = function(...) {
103	1x	cat(isolate(self$format(...)))
104		},
105
106		#' @description
107		#' Returns a complete description of this filter state.
108		#'
109		#' @return A `teal_slice` object.
110		#'
111		get_state = function() {
112	30x	private$teal_slice
113		},
114
115		#' @description
116		#' Does nothing. Exists for compatibility.
117		#'
118		#' @param state (`teal_slice`)
119		#'
120		#' @return `self`, invisibly.
121		#'
122		set_state = function(state) {
123	1x	checkmate::assert_class(state, "teal_slice_expr")
124	1x	invisible(self)
125		},
126
127		#' @description
128		#' Get reproducible call.
129		#'
130		#' @param dataname (`ignored`) for a consistency with `FilterState`
131		#'
132		#' Returns reproducible condition call for current selection relevant
133		#' for selected variable type.
134		#' Method is using internal reactive values which makes it reactive
135		#' and must be executed in reactive or isolated context.
136		#'
137		#' @return `call` or `NULL`
138		#'
139		get_call = function(dataname) {
140	2x	isolate(str2lang(private$teal_slice$expr))
141		},
142
143		#' @description
144		#' Destroy inputs and observers stored in `private$session_bindings`.
145		#'
146		#' @return `NULL`, invisibly.
147		#'
148		finalize = function() {
149	15x	.finalize_session_bindings(self, private)
150	15x	invisible(NULL)
151		},
152
153		# public shiny modules ----
154
155		#' @description
156		#' `shiny` module server.
157		#'
158		#' @param id (`character(1)`)
159		#' `shiny` module instance id.
160		#'
161		#' @param remove_callback (`function`)
162		#' callback to handle removal of this `FilterState` object from `state_list`
163		#'
164		#' @return Reactive expression signaling that the remove button has been clicked.
165		#'
166		server = function(id, remove_callback) {
167	!	moduleServer(
168	!	id = id,
169	!	function(input, output, session) {
170	!	private$server_summary("summary")
171
172	!	private$session_bindings[[session$ns("remove")]] <- observeEvent(
173	!	once = TRUE, # remove button can be called once, should be destroyed afterwards
174	!	ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI
175	!	eventExpr = input$remove, # when remove button is clicked in the FilterState ui
176	!	handlerExpr = remove_callback()
177		)
178
179	!	private$session_bindings[[session$ns("inputs")]] <- list(
180	!	destroy = function() {
181	!	logger::log_debug("Destroying FilterState inputs and observers; id: { private$get_id() }")
182	!	lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
183		}
184		)
185
186	!	NULL
187		}
188		)
189		},
190
191		#' @description
192		#' `shiny` module UI.
193		#' The UI for this class contains simple message stating that it is not supported.
194		#' @param id (`character(1)`)
195		#' `shiny` module instance id.
196		#' @param parent_id (`character(1)`)
197		#' id of the `FilterStates` card container.
198		ui = function(id, parent_id = "cards") {
199	!	ns <- NS(id)
200	!	isolate({
201	!	tags$div(
202	!	id = id,
203	!	class = "panel filter-card",
204	!	include_js_files("count-bar-labels.js"),
205	!	tags$div(
206	!	class = "filter-card-header",
207	!	tags$div(
208	!	class = "filter-card-title",
209	!	if (private$is_anchored()) {
210	!	icon("anchor-lock", class = "filter-card-icon")
211		} else {
212	!	icon("lock", class = "filter-card-icon")
213		},
214	!	tags$div(class = "filter-card-varname", tags$strong(private$teal_slice$id)),
215	!	tags$div(class = "filter-card-varlabel", private$teal_slice$title),
216	!	tags$div(
217	!	class = "filter-card-controls",
218	!	if (isFALSE(private$is_anchored())) {
219	!	actionLink(
220	!	inputId = ns("remove"),
221	!	label = icon("circle-xmark", lib = "font-awesome"),
222	!	title = "Remove filter",
223	!	class = "filter-card-remove"
224		)
225		}
226		)
227		),
228	!	tags$div(
229	!	class = "filter-card-summary",
230	!	private$ui_summary(ns("summary"))
231		)
232		)
233		)
234		})
235		}
236		),
237
238		# private members ----
239
240		private = list(
241		session_bindings = list(), # stores observers and inputs to destroy afterwards
242		teal_slice = NULL, # stores reactiveValues
243
244		# @description
245		# Get id of the teal_slice.
246		# @return `character(1)`
247		get_id = function() {
248	!	isolate(private$teal_slice$id)
249		},
250
251		# Check whether this filter is anchored (cannot be removed).
252		# @return `logical(1)`
253		is_anchored = function() {
254	!	isolate(isTRUE(private$teal_slice$anchored))
255		},
256
257		# @description
258		# Server module to display filter summary
259		# @param id `shiny` id parameter
260		ui_summary = function(id) {
261	!	ns <- NS(id)
262	!	uiOutput(ns("summary"), class = "filter-card-summary")
263		},
264
265		# @description
266		# UI module to display filter summary
267		# @param shiny `id` parameter passed to moduleServer
268		# renders text describing current state
269		server_summary = function(id) {
270	!	moduleServer(
271	!	id = id,
272	!	function(input, output, session) {
273	!	output$summary <- renderUI(private$content_summary())
274		}
275		)
276		},
277		content_summary = function() {
278	!	isolate(private$teal_slice$expr)
279		}
280		)
281		)

1		# SEFilterStates ------
2
3		#' @name SEFilterStates
4		#' @docType class
5		#' @title `FilterStates` subclass for `SummarizedExperiment`s
6		#' @description Handles filter states in a `SummaryExperiment`.
7		#' @keywords internal
8		#'
9		SEFilterStates <- R6::R6Class( # nolint
10		classname = "SEFilterStates",
11		inherit = FilterStates,
12
13		# public methods ----
14		public = list(
15		#' @description
16		#' Initialize `SEFilterStates` object.
17		#'
18		#' @param data (`SummarizedExperiment`)
19		#' the `R` object which `subset` function is applied on.
20		#' @param data_reactive (`function(sid)`)
21		#' should return a `SummarizedExperiment` object or `NULL`.
22		#' This object is needed for the `FilterState` counts being updated on a change in filters.
23		#' If function returns `NULL` then filtered counts are not shown.
24		#' Function has to have `sid` argument being a character.
25		#' @param dataname (`character(1)`)
26		#' name of the data used in the expression
27		#' specified to the function argument attached to this `FilterStates`.
28		#' @param datalabel (`character(1)`) optional
29		#' text label. Should be the name of experiment.
30		#'
31		initialize = function(data,
32		data_reactive = function(sid = "") NULL,
33		dataname,
34		datalabel = NULL) {
35	84x	if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
36	!	stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
37		}
38	84x	checkmate::assert_function(data_reactive, args = "sid")
39	84x	checkmate::assert_class(data, "SummarizedExperiment")
40	83x	super$initialize(data, data_reactive, dataname, datalabel)
41	83x	if (!is.null(datalabel)) {
42	76x	private$dataname_prefixed <- sprintf(
43	76x	"%s[['%s']]", private$dataname_prefixed, datalabel
44		)
45		}
46		},
47
48		#' @description
49		#' Set filter state.
50		#'
51		#' @param state (`teal_slices`)
52		#' `teal_slice` objects should contain the field `arg %in% c("subset", "select")`
53		#'
54		#' @return `NULL`, invisibly.
55		#'
56		set_filter_state = function(state) {
57	53x	isolate({
58	53x	logger::log_debug("SEFilterState$set_filter_state initializing, dataname: { private$dataname }")
59	53x	checkmate::assert_class(state, "teal_slices")
60	51x	lapply(state, function(x) {
61	16x	checkmate::assert_choice(x$arg, choices = c("subset", "select"), null.ok = TRUE, .var.name = "teal_slice$arg")
62		})
63	51x	count_type <- attr(state, "count_type")
64	51x	if (length(count_type)) {
65	8x	private$count_type <- count_type
66		}
67
68	51x	subset_states <- Filter(function(x) x$arg == "subset", state)
69	51x	private$set_filter_state_impl(
70	51x	state = subset_states,
71	51x	data = SummarizedExperiment::rowData(private$data),
72	51x	data_reactive = function(sid = "") {
73	!	data <- private$data_reactive()
74	!	if (!is.null(data)) {
75	!	SummarizedExperiment::rowData(data)
76		}
77		}
78		)
79
80	51x	select_states <- Filter(function(x) x$arg == "select", state)
81	51x	private$set_filter_state_impl(
82	51x	state = select_states,
83	51x	data = SummarizedExperiment::colData(private$data),
84	51x	data_reactive = function(sid = "") {
85	!	data <- private$data_reactive()
86	!	if (!is.null(data)) {
87	!	SummarizedExperiment::colData(data)
88		}
89		}
90		)
91
92	51x	invisible(NULL)
93		})
94		},
95
96		#' @description
97		#' `shiny` UI module to add filter variable.
98		#' @param id (`character(1)`)
99		#' `shiny` module instance id.
100		#' @return `shiny.tag`
101		ui_add = function(id) {
102	2x	data <- private$data
103	2x	checkmate::assert_string(id)
104	2x	ns <- NS(id)
105	2x	row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
106	1x	tags$div("no sample variables available")
107	2x	} else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
108	1x	tags$div("no samples available")
109		} else {
110	!	teal.widgets::optionalSelectInput(
111	!	ns("row_to_add"),
112	!	choices = NULL,
113	!	options = shinyWidgets::pickerOptions(
114	!	liveSearch = TRUE,
115	!	noneSelectedText = "Select gene variable"
116		)
117		)
118		}
119
120	2x	col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
121	1x	tags$div("no sample variables available")
122	2x	} else if (nrow(SummarizedExperiment::colData(data)) == 0) {
123	1x	tags$div("no samples available")
124		} else {
125	!	teal.widgets::optionalSelectInput(
126	!	ns("col_to_add"),
127	!	choices = NULL,
128	!	options = shinyWidgets::pickerOptions(
129	!	liveSearch = TRUE,
130	!	noneSelectedText = "Select sample variable"
131		)
132		)
133		}
134
135	2x	tags$div(
136	2x	row_input,
137	2x	col_input
138		)
139		},
140
141		#' @description
142		#' `shiny` server module to add filter variable.
143		#'
144		#' Module controls available choices to select as a filter variable.
145		#' Selected filter variable is being removed from available choices.
146		#' Removed filter variable gets back to available choices.
147		#' This module unlike other `FilterStates` classes manages two
148		#' sets of filter variables - one for `colData` and another for
149		#' `rowData`.
150		#'
151		#' @param id (`character(1)`)
152		#' `shiny` module instance id.
153		#' @return `NULL`
154		srv_add = function(id) {
155	4x	data <- private$data
156	4x	data_reactive <- private$data_reactive
157	4x	moduleServer(
158	4x	id = id,
159	4x	function(input, output, session) {
160	4x	logger::log_debug("SEFilterState$srv_add initializing, dataname: { private$dataname }")
161
162	4x	row_data <- SummarizedExperiment::rowData(data)
163	4x	col_data <- SummarizedExperiment::colData(data)
164
165	4x	avail_row_data_choices <- reactive({
166	4x	slices_for_subset <- Filter(function(x) x$arg == "subset", self$get_filter_state())
167	4x	active_filter_row_vars <- unique(unlist(lapply(slices_for_subset, "[[", "varname")))
168
169	4x	choices <- setdiff(
170	4x	get_supported_filter_varnames(data = row_data),
171	4x	active_filter_row_vars
172		)
173
174	4x	data_choices_labeled(
175	4x	data = row_data,
176	4x	choices = choices,
177	4x	varlabels = character(0),
178	4x	keys = NULL
179		)
180		})
181
182	4x	avail_col_data_choices <- reactive({
183	4x	slices_for_select <- Filter(function(x) x$arg == "select", self$get_filter_state())
184	4x	active_filter_col_vars <- unique(unlist(lapply(slices_for_select, "[[", "varname")))
185
186	4x	choices <- setdiff(
187	4x	get_supported_filter_varnames(data = col_data),
188	4x	active_filter_col_vars
189		)
190
191	4x	data_choices_labeled(
192	4x	data = col_data,
193	4x	choices = choices,
194	4x	varlabels = character(0),
195	4x	keys = NULL
196		)
197		})
198
199	4x	private$session_bindings[[session$ns("avail_row_data_choices")]] <- observeEvent(
200	4x	avail_row_data_choices(),
201	4x	ignoreNULL = TRUE,
202	4x	handlerExpr = {
203	4x	logger::log_debug(
204	4x	"SEFilterStates$srv_add@1 updating available row data choices,",
205	4x	"dataname: { private$dataname }"
206		)
207	4x	if (is.null(avail_row_data_choices())) {
208	!	shinyjs::hide("row_to_add")
209		} else {
210	4x	shinyjs::show("row_to_add")
211		}
212	4x	teal.widgets::updateOptionalSelectInput(
213	4x	session,
214	4x	"row_to_add",
215	4x	choices = avail_row_data_choices()
216		)
217		}
218		)
219
220	4x	private$session_bindings[[session$ns("avail_col_data_choices")]] <- observeEvent(
221	4x	avail_col_data_choices(),
222	4x	ignoreNULL = TRUE,
223	4x	handlerExpr = {
224	4x	logger::log_debug(
225	4x	"SEFilterStates$srv_add@2 updating available col data choices,",
226	4x	"dataname: { private$dataname }"
227		)
228	4x	if (is.null(avail_col_data_choices())) {
229	!	shinyjs::hide("col_to_add")
230		} else {
231	4x	shinyjs::show("col_to_add")
232		}
233	4x	teal.widgets::updateOptionalSelectInput(
234	4x	session,
235	4x	"col_to_add",
236	4x	choices = avail_col_data_choices()
237		)
238		}
239		)
240
241	4x	private$session_bindings[[session$ns("col_to_add")]] <- observeEvent(
242	4x	eventExpr = input$col_to_add,
243	4x	handlerExpr = {
244	!	logger::log_debug(
245	!	"SEFilterStates$srv_add@3 adding FilterState of column { input$col_to_add }",
246	!	" to col data, dataname: { private$dataname }"
247		)
248	!	varname <- input$col_to_add
249	!	self$set_filter_state(teal_slices(
250	!	teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select")
251		))
252		}
253		)
254
255
256	4x	private$session_bindings[[session$ns("row_to_add")]] <- observeEvent(
257	4x	eventExpr = input$row_to_add,
258	4x	handlerExpr = {
259	!	logger::log_debug(
260	!	"SEFilterStates$srv_add@4 adding FilterState of variable { input$row_to_add }",
261	!	" to row data, dataname: { private$dataname }"
262		)
263	!	varname <- input$row_to_add
264	!	self$set_filter_state(teal_slices(
265	!	teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset")
266		))
267		}
268		)
269
270		# Extra observer that clears all input values in session
271	4x	private$session_bindings[[session$ns("inputs")]] <- list(
272	4x	destroy = function() {
273	!	lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
274		}
275		)
276
277	4x	NULL
278		}
279		)
280		}
281		)
282		)

1		#' Progress bars with labels
2		#'
3		#' `shiny` element displaying a series of progress bars and observation counts.
4		#'
5		#' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input).
6		#' @param choices (`vector`) Available values. Used to determine label text.
7		#' @param countsmax (`numeric`) Maximum counts of each element. Must be the same length `choices`.
8		#' @param countsnow (`numeric`) Current counts of each element. Must be the same length `choices`.
9		#' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`.
10		#'
11		#' @return List of `shiny.tag`s.
12		#'
13		#' Creates a number of progress bar elements, one for each value of `choices`.
14		#' The widths of all progress bars add up to the full width of the container.
15		#' Each progress bar has a text label that contains the name of the value and the number of counts.
16		#'
17		#' If the filter panel is used with `count_type = "all"`, the progress bars will be filled
18		#' according to the number of counts remaining in the current selection and the label will show
19		#' both the current and the total number of counts.
20		#'
21		#' Each child element can have a unique `id` attribute to be used independently.
22		#'
23		#' @examples
24		#' # use non-exported function from teal.slice
25		#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
26		#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
27		#' countBars <- getFromNamespace("countBars", "teal.slice")
28		#' updateCountBars <- getFromNamespace("updateCountBars", "teal.slice")
29		#'
30		#' library(shiny)
31		#'
32		#' choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE)
33		#' counts <- table(choices)
34		#' labels <- countBars(
35		#' inputId = "counts",
36		#' choices = c("a", "b", "c"),
37		#' countsmax = counts,
38		#' countsnow = unname(counts)
39		#' )
40		#'
41		#' ui <- fluidPage(
42		#' tags$div(
43		#' class = "choices_state",
44		#' include_js_files("count-bar-labels.js"),
45		#' include_css_files(pattern = "filter-panel"),
46		#' checkboxGroupInput(
47		#' inputId = "choices",
48		#' selected = levels(choices),
49		#' choiceNames = labels,
50		#' choiceValues = levels(choices),
51		#' label = NULL
52		#' )
53		#' )
54		#' )
55		#' server <- function(input, output, session) {
56		#' observeEvent(input$choices, {
57		#' new_counts <- counts
58		#' new_counts[!names(new_counts) %in% input$choices] <- 0
59		#' updateCountBars(
60		#' inputId = "counts",
61		#' choices = levels(choices),
62		#' countsmax = counts,
63		#' countsnow = unname(new_counts)
64		#' )
65		#' })
66		#' }
67		#'
68		#' if (interactive()) {
69		#' shinyApp(ui, server)
70		#' }
71		#'
72		#' @keywords internal
73		#'
74		countBars <- function(inputId, choices, countsmax, countsnow = NULL) { # nolint
75	27x	checkmate::assert_string(inputId)
76	23x	checkmate::assert_vector(choices)
77	22x	checkmate::assert_numeric(countsmax, len = length(choices))
78	19x	checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)
79	17x	if (!is.null(countsnow)) {
80	9x	checkmate::assert_true(all(countsnow <= countsmax))
81		}
82
83	16x	ns <- NS(inputId)
84
85	16x	mapply(
86	16x	countBar,
87	16x	inputId = ns(seq_along(choices)),
88	16x	label = as.character(choices),
89	16x	countmax = countsmax,
90	16x	countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
91	16x	MoreArgs = list(
92	16x	counttotal = sum(countsmax)
93		),
94	16x	SIMPLIFY = FALSE, USE.NAMES = FALSE
95		)
96		}
97
98		#' Progress bar with label
99		#'
100		#' `shiny` element displaying a progress bar and observation count.
101		#'
102		#' A progress bar is created to visualize the number of counts in a variable, with filling and a text label.
103		#' - progress bar width is derived as a fraction of the container width: `style = "width: <countmax> / <counttotal>%"`,
104		#' - progress bar is filled up to the fraction `<countnow> / <countmax>`,
105		#' - text label is obtained by `<label> (<countnow> / <countmax>)`.
106		#'
107		#' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input).
108		#' @param label (`character(1)`) Text to display followed by counts.
109		#' @param countmax (`numeric(1)`) Maximum count for a single element.
110		#' @param countnow (`numeric(1)`) Current count for a single element.
111		#' @param counttotal (`numeric(1)`) Sum total of maximum counts of all elements, see `Details`.
112		#' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`.
113		#'
114		#' @return `shiny.tag` object with a progress bar and a label.
115		#'
116		#' @keywords internal
117		#'
118		countBar <- function(inputId, label, countmax, countnow = NULL, counttotal = countmax) { # nolint
119	70x	checkmate::assert_string(inputId)
120	66x	checkmate::assert_string(label)
121	63x	checkmate::assert_number(countmax)
122	61x	checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax)
123	59x	checkmate::assert_number(counttotal, lower = countmax)
124
125	57x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
126	57x	ns <- NS(inputId)
127	26x	if (is.null(countnow)) countnow <- 0
128	57x	tags$div(
129	57x	class = "progress state-count-container",
130		# * .9 to not exceed width of the parent html element
131	57x	tags$div(
132	57x	id = ns("count_bar_filtered"),
133	57x	class = "progress-bar state-count-bar-filtered",
134	57x	style = sprintf("width: %s%%", countnow / counttotal * 100),
135	57x	role = "progressbar",
136	57x	label
137		),
138	57x	tags$div(
139	57x	id = ns("count_bar_unfiltered"),
140	57x	class = "progress-bar state-count-bar-unfiltered",
141	57x	style = sprintf("width: %s%%", (countmax - countnow) / counttotal * 100),
142	57x	role = "progressbar"
143		)
144		)
145		}
146
147		#' @rdname countBars
148		updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, countsmax, countsnow = NULL) { # nolint
149	7x	checkmate::assert_string(inputId)
150	7x	checkmate::assert_vector(choices)
151	7x	checkmate::assert_numeric(countsmax, len = length(choices))
152	7x	checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)
153
154	7x	ns <- NS(inputId)
155	7x	mapply(
156	7x	updateCountBar,
157	7x	inputId = ns(seq_along(choices)),
158	7x	label = choices,
159	7x	countmax = countsmax,
160	7x	countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
161	7x	MoreArgs = list(
162	7x	counttotal = sum(countsmax)
163		)
164		)
165	7x	invisible(NULL)
166		}
167
168		#' @rdname countBar
169		updateCountBar <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow = NULL, counttotal) { # nolint
170	18x	checkmate::assert_string(inputId)
171	18x	checkmate::assert_string(label)
172	18x	checkmate::assert_number(countmax)
173	18x	checkmate::assert_number(countnow, null.ok = TRUE)
174	18x	checkmate::assert_number(counttotal)
175
176	18x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
177	18x	if (is.null(countnow)) countnow <- countmax
178	18x	session$sendCustomMessage(
179	18x	type = "updateCountBar",
180	18x	message = list(
181	18x	id = session$ns(inputId),
182	18x	label = label,
183	18x	countmax = countmax,
184	18x	countnow = countnow,
185	18x	counttotal = counttotal
186		)
187		)
188
189	18x	invisible(NULL)
190		}
191
192		#' @rdname countBar
193		updateCountText <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow) { # nolint
194	17x	checkmate::assert_string(inputId)
195	17x	checkmate::assert_string(label)
196	17x	checkmate::assert_number(countmax)
197	17x	checkmate::assert_number(countnow, null.ok = TRUE)
198	17x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
199	17x	session$sendCustomMessage(
200	17x	type = "updateCountText",
201	17x	message = list(
202	17x	id = session$ns(inputId),
203	17x	label = label
204		)
205		)
206		}
207
208		#' Build count text
209		#'
210		#' Returns a text label describing filtered counts. The text is composed in the following way:
211		#' - when `countnow` is not `NULL`: `<label> (<countnow>/<countmax>)`
212		#' - when `countnow` is `NULL`: `<label> (<countmax>)`
213		#'
214		#' @param label (`character(1)`) Text displayed before counts.
215		#' @param countnow (`numeric(1)`) Number of filtered counts.
216		#' @param countmax (`numeric(1)`) Number of unfiltered counts.
217		#'
218		#' @return A character string.
219		#'
220		#' @keywords internal
221		#'
222		make_count_text <- function(label, countmax, countnow = NULL) {
223	104x	checkmate::assert_string(label)
224	102x	checkmate::assert_number(countmax)
225	100x	checkmate::assert_number(countnow, null.ok = TRUE)
226	98x	sprintf(
227	98x	"%s (%s%s)",
228	98x	label,
229	98x	if (is.null(countnow)) "" else sprintf("%s/", countnow),
230	98x	countmax
231		)
232		}
233
234
235		#' Adjust counts to match choices
236		#'
237		#' @param choices (`character`) Choices to match.
238		#' @param counts (`named numeric`) Counts to adjust.
239		#' @keywords internal
240		pair_counts <- function(choices, counts) {
241	160x	checkmate::assert_numeric(counts)
242	160x	counts <- counts[match(choices, names(counts))]
243	160x	counts[is.na(counts)] <- 0
244	160x	names(counts) <- choices
245	160x	counts
246		}

1		#' Include `JS` files from `/inst/js/` package directory to application header
2		#'
3		#' `system.file` should not be used to access files in other packages, it does
4		#' not work with `devtools`. Therefore, we redefine this method in each package
5		#' as needed. Thus, we do not export this method.
6		#'
7		#' @param pattern (`character`) pattern of files to be included, passed to `system.file`
8		#'
9		#' @return HTML code that includes `JS` files
10		#' @keywords internal
11		include_js_files <- function(pattern) {
12	12x	checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE)
13	12x	js_files <- list.files(
14	12x	system.file("js", package = "teal.slice", mustWork = TRUE),
15	12x	pattern = pattern,
16	12x	full.names = TRUE
17		)
18	12x	singleton(lapply(js_files, includeScript))
19		}
20
21		#' Build concatenating call
22		#'
23		#' This function takes a vector of values and returns a `c` call. If the vector
24		#' has only one element, the element is returned directly.
25		#'
26		#' @param choices A vector of values.
27		#'
28		#' @return A `c` call.
29		#'
30		#' @examples
31		#' # use non-exported function from teal.slice
32		#' make_c_call <- getFromNamespace("make_c_call", "teal.slice")
33		#' make_c_call(1:3)
34		#' make_c_call(1)
35		#'
36		#' @keywords internal
37		make_c_call <- function(choices) {
38	55x	if (length(choices) > 1) {
39	27x	do.call("call", append(list("c"), choices))
40		} else {
41	28x	choices
42		}
43		}
44
45		#' Destroys inputs and observers stored in `private$session_bindings`
46		#'
47		#' @description
48		#' Call a `destroy` method to remove `observer` and `input` from obsolete session which happens
49		#' when `filter_panel_srv` is called again in new `FilteredData` object.
50		#' Inputs are not stored directly in a field as they don't have `destroy` method. Instead, we
51		#' store callback `destroy` function for inputs which removes bindings from a `session`.
52		#' @param self,private slots of a `R6` class
53		#' @return `NULL` invisibly
54		#' @keywords internal
55		.finalize_session_bindings <- function(self, private) {
56		# Only finalize shiny session binding when there is an active session
57		if (
58	1306x	!is.null(getDefaultReactiveDomain()) &&
59	1306x	!getDefaultReactiveDomain()$isEnded()
60		) {
61	140x	lapply(private$session_bindings, function(x) x$destroy())
62		}
63	1306x	invisible(NULL)
64		}
65
66
67
68		#' Encodes ids to be used in JavaScript and Shiny
69		#'
70		#' @description
71		#' Replaces non-ASCII characters into a format that can be used in HTML,
72		#' JavaScript and Shiny.
73		#'
74		#' When the id has a character that is not allowed, it is replaced with `"_"`
75		#' and a 4 character hash of the original id is added to the start of the
76		#' resulting id.
77		#'
78		#'
79		#' @param id (`character(1)`) The id string.
80		#'
81		#' @return Sanitized string that removes special characters and spaces.
82		#'
83		#' @keywords internal
84		sanitize_id <- function(id) {
85	392x	pattern_escape <- "[^0-9A-Za-z_]"
86
87	392x	id_new <- gsub(pattern_escape, "_", id, perl = TRUE)
88	392x	hashes <- vapply(id[id != id_new], rlang::hash, character(1), USE.NAMES = FALSE)
89
90	392x	id[id != id_new] <- paste0("h", substr(hashes, 1, 4), "_", id_new[id != id_new])
91	392x	id
92		}
93
94		#' `NS` wrapper to sanitize ids for shiny
95		#'
96		#' Special characters and spaces are not allowed in shiny ids (in JS)
97		#'
98		#' @noRd
99		NS <- function(namespace, id = NULL) { # nolint: object_name.
100	148x	if (!missing(id)) {
101	3x	return(shiny::NS(namespace, sanitize_id(id)))
102		}
103
104	145x	function(id) {
105	282x	shiny::NS(namespace, sanitize_id(id))
106		}
107		}
108
109		#' `moduleServer` wrapper to sanitize ids for shiny
110		#'
111		#' Special characters and spaces are not allowed in shiny ids (in JS)
112		#'
113		#' @noRd
114		moduleServer <- function(id, module, session = getDefaultReactiveDomain()) { # nolint: object_name.
115	107x	id <- sanitize_id(id)
116	107x	shiny::moduleServer(id, module, session)
117		}

1		#' Get classes of selected columns from dataset
2		#'
3		#' @param data (`data.frame` or `DataFrame` or `matrix`) Object in which to determine variable types.
4		#' @param columns (`character`) Vector of columns in `data` for which to get types.
5		#' Set to `NULL` to get types of all columns.
6		#'
7		#' @return Character vector of classes of `columns` from provided `data`.
8		#'
9		#' @examples
10		#' # use non-exported function from teal.slice
11		#' variable_types <- getFromNamespace("variable_types", "teal.slice")
12		#'
13		#' variable_types(
14		#' data.frame(
15		#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
16		#' stringsAsFactors = FALSE
17		#' ),
18		#' "x"
19		#' )
20		#'
21		#' variable_types(
22		#' data.frame(
23		#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
24		#' stringsAsFactors = FALSE
25		#' ),
26		#' c("x", "z")
27		#' )
28		#'
29		#' variable_types(
30		#' data.frame(
31		#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
32		#' stringsAsFactors = FALSE
33		#' )
34		#' )
35		#'
36		#' @keywords internal
37		#'
38		variable_types <- function(data, columns = NULL) {
39	19x	checkmate::assert_multi_class(data, c("data.frame", "DataFrame", "matrix"))
40	19x	checkmate::assert_character(columns, any.missing = FALSE, null.ok = TRUE)
41	19x	checkmate::assert_subset(columns, colnames(data))
42
43	19x	if (is.matrix(data)) {
44	1x	type <- typeof(data)
45	1x	if (type == "double") type <- "numeric"
46	1x	types <-
47	1x	if (is.null(columns)) {
48	!	stats::setNames(rep_len(type, ncol(data)), nm = colnames(data))
49		} else {
50	1x	stats::setNames(rep_len(type, length(columns)), nm = columns)
51		}
52		} else {
53	18x	types <- vapply(data, function(x) class(x)[1L], character(1L))
54	18x	if (!is.null(columns)) types <- types[columns]
55		# alternative after R 4.4.0: `types <- types[columns %\|\|% TRUE]`
56		}
57	19x	types
58		}

1		# MAEFilteredDataset ------
2
3		#' @name MAEFilteredDataset
4		#' @docType class
5		#' @title `MAEFilteredDataset` `R6` class
6		#'
7		#' @examplesIf requireNamespace("MultiAssayExperiment")
8		#' # use non-exported function from teal.slice
9		#' MAEFilteredDataset <- getFromNamespace("MAEFilteredDataset", "teal.slice")
10		#'
11		#' data(miniACC, package = "MultiAssayExperiment")
12		#' dataset <- MAEFilteredDataset$new(miniACC, "MAE")
13		#' fs <- teal_slices(
14		#' teal_slice(
15		#' dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE
16		#' ),
17		#' teal_slice(
18		#' dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE
19		#' ),
20		#' teal_slice(
21		#' dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE
22		#' ),
23		#' teal_slice(
24		#' dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE
25		#' )
26		#' )
27		#' dataset$set_filter_state(state = fs)
28		#'
29		#' library(shiny)
30		#' isolate(dataset$get_filter_state())
31		#'
32		#' @keywords internal
33		#'
34		MAEFilteredDataset <- R6::R6Class( # nolint
35		classname = "MAEFilteredDataset",
36		inherit = FilteredDataset,
37
38		# public methods ----
39		public = list(
40		#' @description
41		#' Initialize `MAEFilteredDataset` object.
42		#'
43		#' @param dataset (`MulitiAssayExperiment`)
44		#' single `MulitiAssayExperiment` for which filters are rendered.
45		#' @param dataname (`character(1)`)
46		#' syntactically valid name given to the dataset.
47		#' @param keys (`character`) optional
48		#' vector of primary key column names.
49		#' @param label (`character(1)`)
50		#' label to describe the dataset.
51		#'
52		#' @return Object of class `MAEFilteredDataset`, invisibly.
53		#'
54		initialize = function(dataset, dataname, keys = character(0), label = character(0)) {
55	21x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
56	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
57		}
58	21x	checkmate::assert_class(dataset, "MultiAssayExperiment")
59	19x	super$initialize(dataset, dataname, keys, label)
60	19x	experiment_names <- names(dataset)
61
62		# subsetting by subjects means subsetting by colData(MAE)
63	19x	private$add_filter_states(
64	19x	filter_states = init_filter_states(
65	19x	data = dataset,
66	19x	data_reactive = private$data_filtered_fun,
67	19x	dataname = dataname,
68	19x	datalabel = "subjects",
69	19x	keys = self$get_keys()
70		),
71	19x	id = "subjects"
72		)
73		# elements of the list (experiments) are unknown
74		# dispatch needed because we can't hardcode methods otherwise:
75		# if (matrix) else if (SummarizedExperiment) else if ...
76	19x	lapply(
77	19x	experiment_names,
78	19x	function(experiment_name) {
79	95x	data_reactive <- function(sid = "") private$data_filtered_fun(sid)[[experiment_name]]
80	95x	private$add_filter_states(
81	95x	filter_states = init_filter_states(
82	95x	data = dataset[[experiment_name]],
83	95x	data_reactive = data_reactive,
84	95x	dataname = dataname,
85	95x	datalabel = experiment_name
86		),
87	95x	id = experiment_name
88		)
89		}
90		)
91		},
92
93		#' @description
94		#' Set filter state.
95		#'
96		#' @param state (`teal_slices`)
97		#' @return `NULL`, invisibly.
98		#'
99		set_filter_state = function(state) {
100	13x	isolate({
101	13x	logger::log_debug("FilteredDatasetMAE$set_filter_state initializing, dataname: { private$dataname }")
102	13x	checkmate::assert_class(state, "teal_slices")
103	12x	lapply(state, function(x) {
104	48x	checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname")
105		})
106
107		# set state on subjects
108	12x	subject_state <- Filter(function(x) is.null(x$experiment), state)
109	12x	private$get_filter_states()[["subjects"]]$set_filter_state(subject_state)
110
111		# set state on experiments
112		# determine target experiments (defined in teal_slices)
113	12x	experiments <- unique(unlist(lapply(state, "[[", "experiment")))
114	12x	available_experiments <- setdiff(names(private$get_filter_states()), "subjects")
115	12x	excluded_filters <- setdiff(experiments, available_experiments)
116	12x	if (length(excluded_filters)) {
117	!	stop(sprintf(
118	!	"%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",
119	!	private$dataname,
120	!	toString(excluded_filters),
121	!	toString(available_experiments)
122		))
123		}
124
125		# set states on state_lists with corresponding experiments
126	12x	lapply(available_experiments, function(experiment) {
127	60x	slices <- Filter(function(x) identical(x$experiment, experiment), state)
128	60x	private$get_filter_states()[[experiment]]$set_filter_state(slices)
129		})
130
131	12x	invisible(NULL)
132		})
133		},
134
135		#' @description
136		#' Remove one or more `FilterState` of a `MAEFilteredDataset`.
137		#'
138		#' @param state (`teal_slices`)
139		#' specifying `FilterState` objects to remove;
140		#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored.
141		#'
142		#' @return `NULL`, invisibly.
143		#'
144		remove_filter_state = function(state) {
145	1x	checkmate::assert_class(state, "teal_slices")
146
147	1x	isolate({
148	1x	logger::log_debug("FilteredDatasetMAE$remove_filter_state removing filter(s), dataname: { private$dataname }")
149		# remove state on subjects
150	1x	subject_state <- Filter(function(x) is.null(x$experiment), state)
151	1x	private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state)
152
153		# remove state on experiments
154		# determine target experiments (defined in teal_slices)
155	1x	experiments <- unique(unlist(lapply(state, "[[", "experiment")))
156	1x	available_experiments <- setdiff(names(private$get_filter_states()), "subjects")
157	1x	excluded_filters <- setdiff(experiments, available_experiments)
158	1x	if (length(excluded_filters)) {
159	!	stop(sprintf(
160	!	"%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",
161	!	private$dataname,
162	!	toString(excluded_filters),
163	!	toString(available_experiments)
164		))
165		}
166		# remove states on state_lists with corresponding experiments
167	1x	lapply(experiments, function(experiment) {
168	!	slices <- Filter(function(x) identical(x$experiment, experiment), state)
169	!	private$get_filter_states()[[experiment]]$remove_filter_state(slices)
170		})
171		})
172
173	1x	invisible(NULL)
174		},
175
176		#' @description
177		#' UI module to add filter variable for this dataset.
178		#' @param id (`character(1)`)
179		#' `shiny` module instance id.
180		#'
181		#' @return `shiny.tag`
182		#'
183		ui_add = function(id) {
184	!	ns <- NS(id)
185	!	data <- self$get_dataset()
186	!	experiment_names <- names(data)
187
188	!	tags$div(
189	!	tags$label("Add", tags$code(self$get_dataname()), "filter"),
190	!	tags$br(),
191	!	HTML("►"),
192	!	tags$label("Add subjects filter"),
193	!	private$get_filter_states()[["subjects"]]$ui_add(id = ns("subjects")),
194	!	tagList(
195	!	lapply(
196	!	experiment_names,
197	!	function(experiment_name) {
198	!	tagList(
199	!	HTML("►"),
200	!	tags$label("Add", tags$code(experiment_name), "filter"),
201	!	private$get_filter_states()[[experiment_name]]$ui_add(id = ns(experiment_name))
202		)
203		}
204		)
205		)
206		)
207		},
208
209		#' @description
210		#' Creates row for filter overview in the form of \cr
211		#' `dataname -- observations (remaining/total) -- subjects (remaining/total)` - MAE
212		#' @return A `data.frame`.
213		get_filter_overview = function() {
214	2x	data <- self$get_dataset()
215	2x	data_filtered <- self$get_dataset(TRUE)
216	2x	experiment_names <- names(data)
217
218	2x	mae_info <- data.frame(
219	2x	dataname = private$dataname,
220	2x	subjects = nrow(SummarizedExperiment::colData(data)),
221	2x	subjects_filtered = nrow(SummarizedExperiment::colData(data_filtered()))
222		)
223
224	2x	experiment_obs_info <- do.call("rbind", lapply(
225	2x	experiment_names,
226	2x	function(experiment_name) {
227	10x	data.frame(
228	10x	dataname = sprintf("- %s", experiment_name),
229	10x	obs = nrow(data[[experiment_name]]),
230	10x	obs_filtered = nrow(data_filtered()[[experiment_name]])
231		)
232		}
233		))
234
235	2x	get_experiment_keys <- function(mae, experiment) {
236	20x	sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment))
237	20x	length(unique(sample_subset$primary))
238		}
239
240	2x	experiment_subjects_info <- do.call("rbind", lapply(
241	2x	experiment_names,
242	2x	function(experiment_name) {
243	10x	data.frame(
244	10x	subjects = get_experiment_keys(data, data[[experiment_name]]),
245	10x	subjects_filtered = get_experiment_keys(data_filtered(), data_filtered()[[experiment_name]])
246		)
247		}
248		))
249
250	2x	experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)
251	2x	dplyr::bind_rows(mae_info, experiment_info)
252		}
253		)
254		)

1		# ChoicesFilterState ------
2
3		#' @name ChoicesFilterState
4		#' @docType class
5		#'
6		#' @title `FilterState` object for categorical data
7		#'
8		#' @description Manages choosing elements from a set.
9		#'
10		#' @examples
11		#' # use non-exported function from teal.slice
12		#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
13		#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
14		#' ChoicesFilterState <- getFromNamespace("ChoicesFilterState", "teal.slice")
15		#'
16		#' library(shiny)
17		#'
18		#' filter_state <- ChoicesFilterState$new(
19		#' x = c(LETTERS, NA),
20		#' slice = teal_slice(varname = "var", dataname = "data")
21		#' )
22		#' isolate(filter_state$get_call())
23		#' filter_state$set_state(
24		#' teal_slice(
25		#' dataname = "data",
26		#' varname = "var",
27		#' selected = "A",
28		#' keep_na = TRUE
29		#' )
30		#' )
31		#' isolate(filter_state$get_call())
32		#'
33		#' # working filter in an app
34		#' library(shinyjs)
35		#'
36		#' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA)
37		#' attr(data_choices, "label") <- "lowercase letters"
38		#' fs <- ChoicesFilterState$new(
39		#' x = data_choices,
40		#' slice = teal_slice(
41		#' dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE
42		#' )
43		#' )
44		#'
45		#' ui <- fluidPage(
46		#' useShinyjs(),
47		#' include_css_files(pattern = "filter-panel"),
48		#' include_js_files(pattern = "count-bar-labels"),
49		#' column(4, tags$div(
50		#' tags$h4("ChoicesFilterState"),
51		#' fs$ui("fs")
52		#' )),
53		#' column(4, tags$div(
54		#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
55		#' textOutput("condition_choices"), tags$br(),
56		#' tags$h4("Unformatted state"), # display raw filter state
57		#' textOutput("unformatted_choices"), tags$br(),
58		#' tags$h4("Formatted state"), # display human readable filter state
59		#' textOutput("formatted_choices"), tags$br()
60		#' )),
61		#' column(4, tags$div(
62		#' tags$h4("Programmatic filter control"),
63		#' actionButton("button1_choices", "set drop NA", width = "100%"), tags$br(),
64		#' actionButton("button2_choices", "set keep NA", width = "100%"), tags$br(),
65		#' actionButton("button3_choices", "set selection: a, b", width = "100%"), tags$br(),
66		#' actionButton("button4_choices", "deselect all", width = "100%"), tags$br(),
67		#' actionButton("button0_choices", "set initial state", width = "100%"), tags$br()
68		#' ))
69		#' )
70		#'
71		#' server <- function(input, output, session) {
72		#' fs$server("fs")
73		#' output$condition_choices <- renderPrint(fs$get_call())
74		#' output$formatted_choices <- renderText(fs$format())
75		#' output$unformatted_choices <- renderPrint(fs$get_state())
76		#' # modify filter state programmatically
77		#' observeEvent(
78		#' input$button1_choices,
79		#' fs$set_state(
80		#' teal_slice(dataname = "data", varname = "variable", keep_na = FALSE)
81		#' )
82		#' )
83		#' observeEvent(
84		#' input$button2_choices,
85		#' fs$set_state(
86		#' teal_slice(dataname = "data", varname = "variable", keep_na = TRUE)
87		#' )
88		#' )
89		#' observeEvent(
90		#' input$button3_choices,
91		#' fs$set_state(
92		#' teal_slice(dataname = "data", varname = "variable", selected = c("a", "b"))
93		#' )
94		#' )
95		#' observeEvent(
96		#' input$button4_choices,
97		#' fs$set_state(
98		#' teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE)
99		#' )
100		#' )
101		#' observeEvent(
102		#' input$button0_choices,
103		#' fs$set_state(
104		#' teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE)
105		#' )
106		#' )
107		#' }
108		#'
109		#' if (interactive()) {
110		#' shinyApp(ui, server)
111		#' }
112		#'
113		#' @keywords internal
114		#'
115		ChoicesFilterState <- R6::R6Class( # nolint
116		"ChoicesFilterState",
117		inherit = FilterState,
118
119		# public methods ----
120
121		public = list(
122
123		#' @description
124		#' Initialize a `FilterState` object.
125		#'
126		#' @param x (`character`)
127		#' variable to be filtered.
128		#' @param x_reactive (`reactive`)
129		#' returning vector of the same type as `x`. Is used to update
130		#' counts following the change in values of the filtered dataset.
131		#' If it is set to `reactive(NULL)` then counts based on filtered
132		#' dataset are not shown.
133		#' @param slice (`teal_slice`)
134		#' specification of this filter state.
135		#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
136		#' `get_state` returns `teal_slice` object which can be reused in other places.
137		#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
138		#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
139		#' @param extract_type (`character`)
140		#' specifying whether condition calls should be prefixed by `dataname`. Possible values:
141		#' - `character(0)` (default) `varname` in the condition call will not be prefixed
142		#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
143		#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
144		#'
145		#' @return Object of class `ChoicesFilterState`, invisibly.
146		#'
147		initialize = function(x,
148		x_reactive = reactive(NULL),
149		slice,
150		extract_type = character(0)) {
151	158x	isolate({
152	158x	checkmate::assert(
153	158x	is.character(x),
154	158x	is.factor(x),
155	158x	length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
156	158x	combine = "or"
157		)
158	158x	if (is.factor(x)) {
159	37x	x <- droplevels(x)
160		}
161	158x	super$initialize(
162	158x	x = x,
163	158x	x_reactive = x_reactive,
164	158x	slice = slice,
165	158x	extract_type = extract_type
166		)
167	158x	private$set_choices(slice$choices)
168	158x	if (is.null(slice$selected) && slice$multiple) {
169	45x	slice$selected <- private$get_choices()
170	113x	} else if (is.null(slice$selected)) {
171	1x	slice$selected <- private$get_choices()[1]
172	112x	} else if (length(slice$selected) > 1 && !slice$multiple) {
173	1x	warning(
174	1x	"ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ",
175	1x	"Only the first value will be used."
176		)
177	1x	slice$selected <- slice$selected[1]
178		}
179	158x	private$set_selected(slice$selected)
180	158x	if (inherits(x, "POSIXt")) {
181	9x	private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))
182		}
183		})
184	158x	invisible(self)
185		},
186
187		#' @description
188		#' Returns reproducible condition call for current selection.
189		#' For this class returned call looks like
190		#' `<varname> %in% c(<values selected>)` with optional `is.na(<varname>)`.
191		#' @param dataname (`character(1)`) name of data set; defaults to `private$get_dataname()`
192		#' @return `call` or `NULL`
193		#'
194		get_call = function(dataname) {
195	61x	if (isFALSE(private$is_any_filtered())) {
196	7x	return(NULL)
197		}
198	30x	if (missing(dataname)) dataname <- private$get_dataname()
199	54x	varname <- private$get_varname_prefixed(dataname)
200	54x	choices <- private$get_choices()
201	54x	selected <- private$get_selected()
202	54x	fun_compare <- if (length(selected) == 1L) "==" else "%in%"
203	54x	filter_call <- if (length(selected) == 0) {
204	6x	call("!", call(fun_compare, varname, make_c_call(as.character(choices))))
205		} else {
206	48x	if (setequal(selected, choices) && !private$is_choice_limited) {
207	2x	NULL
208	46x	} else if (inherits(private$x, "Date")) {
209	1x	call(fun_compare, varname, call("as.Date", make_c_call(as.character(selected))))
210	45x	} else if (inherits(private$x, c("POSIXct", "POSIXlt"))) {
211	2x	class <- class(private$x)[1L]
212	2x	date_fun <- as.name(
213	2x	switch(class,
214	2x	"POSIXct" = "as.POSIXct",
215	2x	"POSIXlt" = "as.POSIXlt"
216		)
217		)
218	2x	call(
219	2x	fun_compare,
220	2x	varname,
221	2x	as.call(list(date_fun, make_c_call(as.character(selected)), tz = private$tzone))
222		)
223	43x	} else if (is.numeric(private$x)) {
224	7x	call(fun_compare, varname, make_c_call(as.numeric(selected)))
225		} else {
226		# This handles numerics, characters, and factors.
227	36x	call(fun_compare, varname, make_c_call(selected))
228		}
229		}
230	54x	private$add_keep_na_call(filter_call, varname)
231		}
232		),
233
234		# private members ----
235		private = list(
236		x = NULL,
237		choices_counts = integer(0),
238		tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call
239
240		# private methods ----
241
242		# @description
243		# Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices
244		# are limited by default from the start.
245		set_choices = function(choices) {
246	158x	named_counts <- .table(private$x)
247	158x	possible_choices <- names(named_counts)
248	158x	if (is.null(choices)) {
249	143x	choices <- possible_choices
250		} else {
251	15x	choices <- as.character(choices)
252	15x	choices_adjusted <- choices[choices %in% possible_choices]
253	15x	if (length(setdiff(choices, choices_adjusted)) > 0L) {
254	2x	warning(
255	2x	sprintf(
256	2x	"Some choices not found in data. Adjusting. Filter id: %s.",
257	2x	private$get_id()
258		)
259		)
260	2x	choices <- choices_adjusted
261		}
262	15x	if (length(choices) == 0) {
263	1x	warning(
264	1x	sprintf(
265	1x	"None of the choices were found in data. Setting defaults. Filter id: %s.",
266	1x	private$get_id()
267		)
268		)
269	1x	choices <- possible_choices
270		}
271		}
272	158x	private$set_choices_counts(
273	158x	pair_counts(choices, named_counts)
274		)
275	158x	private$set_is_choice_limited(possible_choices, choices)
276	158x	private$teal_slice$choices <- choices
277	158x	invisible(NULL)
278		},
279		# @description
280		# Check whether the initial choices filter out some values of x and set the flag in case.
281		set_is_choice_limited = function(x, choices) {
282	158x	xl <- x[!is.na(x)]
283	158x	private$is_choice_limited <- length(setdiff(xl, choices)) > 0L
284	158x	invisible(NULL)
285		},
286		# @description
287		# Sets choices_counts private field.
288		set_choices_counts = function(choices_counts) {
289	158x	private$choices_counts <- choices_counts
290	158x	invisible(NULL)
291		},
292		# @description
293		# Checks whether the input should be rendered as a checkboxgroup/radiobutton or a drop-down.
294		is_checkboxgroup = function() {
295	25x	length(private$get_choices()) <= getOption("teal.threshold_slider_vs_checkboxgroup")
296		},
297		cast_and_validate = function(values) {
298	187x	tryCatch(
299	187x	expr = {
300	187x	values <- as.character(values)
301	!	if (anyNA(values)) stop()
302		},
303	187x	error = function(e) stop("The vector of set values must contain values coercible to character.")
304		)
305	187x	values
306		},
307		# If multiple forbidden but selected, restores previous selection with warning.
308		check_length = function(values) {
309	187x	if (!private$is_multiple() && length(values) > 1) {
310	1x	warning(
311	1x	sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
312	1x	"Maintaining previous selection."
313		)
314	1x	values <- isolate(private$get_selected())
315		}
316	187x	values
317		},
318		remove_out_of_bounds_values = function(values) {
319	187x	in_choices_mask <- values %in% private$get_choices()
320	187x	if (length(values[!in_choices_mask]) > 0) {
321	17x	warning(paste(
322	17x	"Values:", toString(values[!in_choices_mask], width = 360),
323	17x	"are not in choices of column", private$get_varname(), "in dataset", private$get_dataname(), "."
324		))
325		}
326	187x	values[in_choices_mask]
327		},
328
329		# shiny modules ----
330
331		# @description
332		# UI Module for `ChoicesFilterState`.
333		# This UI element contains available choices selection and
334		# checkbox whether to keep or not keep the `NA` values.
335		# @param id (`character(1)`) `shiny` module instance id.
336		ui_inputs = function(id) {
337	9x	ns <- NS(id)
338
339		# we need to isolate UI to not retrigger renderUI
340	9x	isolate({
341	9x	countsmax <- private$choices_counts
342	9x	countsnow <- if (!is.null(private$x_reactive())) {
343	2x	pair_counts(
344	2x	private$get_choices(),
345	2x	.table(private$x_reactive())
346		)
347		}
348
349	9x	ui_input <- if (private$is_checkboxgroup()) {
350	9x	labels <- countBars(
351	9x	inputId = ns("labels"),
352	9x	choices = private$get_choices(),
353	9x	countsnow = countsnow,
354	9x	countsmax = countsmax
355		)
356	9x	tags$div(
357	9x	class = "choices_state",
358	9x	if (private$is_multiple()) {
359	9x	checkboxGroupInput(
360	9x	inputId = ns("selection"),
361	9x	label = NULL,
362	9x	selected = private$get_selected(),
363	9x	choiceNames = labels,
364	9x	choiceValues = private$get_choices(),
365	9x	width = "100%"
366		)
367		} else {
368	!	radioButtons(
369	!	inputId = ns("selection"),
370	!	label = NULL,
371	!	selected = private$get_selected(),
372	!	choiceNames = labels,
373	!	choiceValues = private$get_choices(),
374	!	width = "100%"
375		)
376		}
377		)
378		} else {
379	!	labels <- mapply(
380	!	FUN = make_count_text,
381	!	label = private$get_choices(),
382	!	countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,
383	!	countmax = countsmax
384		)
385
386	!	teal.widgets::optionalSelectInput(
387	!	inputId = ns("selection"),
388	!	choices = stats::setNames(private$get_choices(), labels),
389	!	selected = private$get_selected(),
390	!	multiple = private$is_multiple(),
391	!	options = shinyWidgets::pickerOptions(
392	!	actionsBox = TRUE,
393	!	liveSearch = (length(private$get_choices()) > 10),
394	!	noneSelectedText = "Select a value"
395		)
396		)
397		}
398	9x	tags$div(
399	9x	uiOutput(ns("trigger_visible")),
400	9x	ui_input,
401	9x	private$keep_na_ui(ns("keep_na"))
402		)
403		})
404		},
405
406		# @description
407		# Server module
408		# @param id (`character(1)`) `shiny` module instance id.
409		# @return `NULL`.
410		server_inputs = function(id) {
411	7x	moduleServer(
412	7x	id = id,
413	7x	function(input, output, session) {
414	7x	logger::log_debug("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }")
415		# 1. renderUI is used here as an observer which triggers only if output is visible
416		# and if the reactive changes - reactive triggers only if the output is visible.
417		# 2. We want to trigger change of the labels only if reactive count changes (not underlying data)
418	7x	non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))
419	7x	output$trigger_visible <- renderUI({
420	7x	logger::log_debug("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")
421
422	7x	countsnow <- if (!is.null(private$x_reactive())) {
423	!	pair_counts(
424	!	private$get_choices(),
425	!	.table(non_missing_values())
426		)
427		}
428
429		# update should be based on a change of counts only
430	7x	isolate({
431	7x	if (private$is_checkboxgroup()) {
432	7x	updateCountBars(
433	7x	inputId = "labels",
434	7x	choices = private$get_choices(),
435	7x	countsmax = private$choices_counts,
436	7x	countsnow = countsnow
437		)
438		} else {
439	!	labels <- mapply(
440	!	FUN = make_count_text,
441	!	label = private$get_choices(),
442	!	countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,
443	!	countmax = private$choices_counts
444		)
445	!	teal.widgets::updateOptionalSelectInput(
446	!	session = session,
447	!	inputId = "selection",
448	!	choices = stats::setNames(private$get_choices(), labels),
449	!	selected = private$get_selected()
450		)
451		}
452	7x	NULL
453		})
454		})
455
456	7x	private$session_bindings[[session$ns("selection")]] <- if (private$is_checkboxgroup()) {
457	7x	observeEvent(
458	7x	ignoreNULL = FALSE,
459	7x	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
460	7x	eventExpr = input$selection,
461	7x	handlerExpr = {
462	!	logger::log_debug("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
463
464	!	selection <- if (is.null(input$selection) && private$is_multiple()) {
465	!	character(0)
466		} else {
467	!	input$selection
468		}
469
470	!	private$set_selected(selection)
471		}
472		)
473		} else {
474	!	observeEvent(
475	!	ignoreNULL = FALSE,
476	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
477	!	eventExpr = input$selection_open, # observe click on a dropdown
478	!	handlerExpr = {
479	!	if (!isTRUE(input$selection_open)) { # only when the dropdown got closed
480	!	logger::log_debug("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
481
482	!	selection <- if (is.null(input$selection) && private$is_multiple()) {
483	!	character(0)
484	!	} else if (isTRUE(length(input$selection) != 1) && !private$is_multiple()) {
485		# In optionalSelectInput user is able to select mutliple options. But if FilterState is not multiple
486		# we should prevent this selection to be processed further.
487		# This is why notification is thrown and dropdown is changed back to latest selected.
488	!	showNotification(paste(
489	!	"This filter exclusively supports single selection.",
490	!	"Any additional choices made will be disregarded."
491		))
492	!	teal.widgets::updateOptionalSelectInput(
493	!	session, "selection",
494	!	selected = private$get_selected()
495		)
496	!	return(NULL)
497		} else {
498	!	input$selection
499		}
500	!	private$set_selected(selection)
501		}
502		}
503		)
504		}
505
506	7x	private$keep_na_srv("keep_na")
507
508		# this observer is needed in the situation when teal_slice$selected has been
509		# changed directly by the api - then it's needed to rerender UI element
510		# to show relevant values
511	7x	private$session_bindings[[session$ns("selection_api")]] <- observeEvent(private$get_selected(), {
512		# it's important to not retrigger when the input$selection is the same as reactive values
513		# kept in the teal_slice$selected
514	2x	if (!setequal(input$selection, private$get_selected())) {
515	2x	logger::log_debug("ChoicesFilterState$server@1 state changed, id: { private$get_id() }")
516	2x	if (private$is_checkboxgroup()) {
517	2x	if (private$is_multiple()) {
518	2x	updateCheckboxGroupInput(
519	2x	inputId = "selection",
520	2x	selected = private$get_selected()
521		)
522		} else {
523	!	updateRadioButtons(
524	!	inputId = "selection",
525	!	selected = private$get_selected()
526		)
527		}
528		} else {
529	!	teal.widgets::updateOptionalSelectInput(
530	!	session, "selection",
531	!	selected = private$get_selected()
532		)
533		}
534		}
535		})
536
537	7x	NULL
538		}
539		)
540		},
541		server_inputs_fixed = function(id) {
542	!	moduleServer(
543	!	id = id,
544	!	function(input, output, session) {
545	!	logger::log_debug("ChoicesFilterState$server_inputs_fixed initializing, id: { private$get_id() }")
546
547	!	output$selection <- renderUI({
548	!	countsnow <- if (!is.null(private$x_reactive())) {
549	!	pair_counts(
550	!	private$get_choices(),
551	!	.table(private$x_reactive())
552		)
553		}
554	!	countsmax <- private$choices_counts
555
556	!	ind <- private$get_choices() %in% isolate(private$get_selected())
557	!	countBars(
558	!	inputId = session$ns("labels"),
559	!	choices = isolate(private$get_selected()),
560	!	countsnow = countsnow[ind],
561	!	countsmax = countsmax[ind]
562		)
563		})
564
565	!	NULL
566		}
567		)
568		},
569
570		# @description
571		# UI module to display filter summary
572		# renders text describing number of selected levels
573		# and if NA are included also
574		content_summary = function(id) {
575	7x	selected <- private$get_selected()
576	7x	selected_text <-
577	7x	if (length(selected) == 0L) {
578	!	"no selection"
579		} else {
580	7x	if (sum(nchar(selected)) <= 40L) {
581	7x	paste(selected, collapse = ", ")
582		} else {
583	!	paste(length(selected), "levels selected")
584		}
585		}
586	7x	tagList(
587	7x	tags$span(
588	7x	class = "filter-card-summary-value",
589	7x	selected_text
590		),
591	7x	tags$span(
592	7x	class = "filter-card-summary-controls",
593	7x	if (private$na_count > 0) {
594	!	tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
595		}
596		)
597		)
598		}
599		)
600		)
601
602		#' `table` handling `POSIXlt`
603		#'
604		#' @param x (`vector`) variable to get counts from.
605		#' @return vector of counts named by unique values of `x`.
606		#'
607		#' @keywords internal
608		.table <- function(x) {
609	160x	tbl <- table(
610	160x	if (is.factor(x)) {
611	37x	x
612		} else {
613	123x	as.character(x)
614		}
615		)
616		# tbl returns an array with dimnames instead of a simple vector
617		# we need to convert it to a vector so the object is simpler to handle
618	160x	stats::setNames(
619	160x	as.vector(tbl),
620	160x	names(tbl)
621		)
622		}

1		# DateFilterState ------
2
3		#' @name DateFilterState
4		#' @docType class
5		#'
6		#' @title `FilterState` object for `Date` data
7		#'
8		#' @description Manages choosing a range of `Date`s.
9		#'
10		#' @examples
11		#' # use non-exported function from teal.slice
12		#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
13		#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
14		#' DateFilterState <- getFromNamespace("DateFilterState", "teal.slice")
15		#'
16		#' library(shiny)
17		#'
18		#' filter_state <- DateFilterState$new(
19		#' x = c(Sys.Date() + seq(1:10), NA),
20		#' slice = teal_slice(varname = "x", dataname = "data"),
21		#' extract_type = character(0)
22		#' )
23		#' isolate(filter_state$get_call())
24		#' filter_state$set_state(
25		#' teal_slice(
26		#' dataname = "data",
27		#' varname = "x",
28		#' selected = c(Sys.Date() + 3L, Sys.Date() + 8L),
29		#' keep_na = TRUE
30		#' )
31		#' )
32		#' isolate(filter_state$get_call())
33		#'
34		#' # working filter in an app
35		#' library(shinyjs)
36		#'
37		#' dates <- c(Sys.Date() - 100, Sys.Date())
38		#' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA)
39		#' fs <- DateFilterState$new(
40		#' x = data_date,
41		#' slice = teal_slice(
42		#' dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE
43		#' )
44		#' )
45		#'
46		#' ui <- fluidPage(
47		#' useShinyjs(),
48		#' include_css_files(pattern = "filter-panel"),
49		#' include_js_files(pattern = "count-bar-labels"),
50		#' column(4, tags$div(
51		#' tags$h4("DateFilterState"),
52		#' fs$ui("fs")
53		#' )),
54		#' column(4, tags$div(
55		#' id = "outputs", # div id is needed for toggling the element
56		#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
57		#' textOutput("condition_date"), tags$br(),
58		#' tags$h4("Unformatted state"), # display raw filter state
59		#' textOutput("unformatted_date"), tags$br(),
60		#' tags$h4("Formatted state"), # display human readable filter state
61		#' textOutput("formatted_date"), tags$br()
62		#' )),
63		#' column(4, tags$div(
64		#' tags$h4("Programmatic filter control"),
65		#' actionButton("button1_date", "set drop NA", width = "100%"), tags$br(),
66		#' actionButton("button2_date", "set keep NA", width = "100%"), tags$br(),
67		#' actionButton("button3_date", "set a range", width = "100%"), tags$br(),
68		#' actionButton("button4_date", "set full range", width = "100%"), tags$br(),
69		#' actionButton("button0_date", "set initial state", width = "100%"), tags$br()
70		#' ))
71		#' )
72		#'
73		#' server <- function(input, output, session) {
74		#' fs$server("fs")
75		#' output$condition_date <- renderPrint(fs$get_call())
76		#' output$formatted_date <- renderText(fs$format())
77		#' output$unformatted_date <- renderPrint(fs$get_state())
78		#' # modify filter state programmatically
79		#' observeEvent(
80		#' input$button1_date,
81		#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
82		#' )
83		#' observeEvent(
84		#' input$button2_date,
85		#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
86		#' )
87		#' observeEvent(
88		#' input$button3_date,
89		#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)]))
90		#' )
91		#' observeEvent(
92		#' input$button4_date,
93		#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates))
94		#' )
95		#' observeEvent(
96		#' input$button0_date,
97		#' fs$set_state(
98		#' teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE)
99		#' )
100		#' )
101		#' }
102		#'
103		#' if (interactive()) {
104		#' shinyApp(ui, server)
105		#' }
106		#'
107		#' @keywords internal
108		#'
109		DateFilterState <- R6::R6Class( # nolint
110		"DateFilterState",
111		inherit = FilterState,
112
113		# public methods ----
114
115		public = list(
116
117		#' @description
118		#' Initialize a `FilterState` object.
119		#'
120		#' @param x (`Date`)
121		#' variable to be filtered.
122		#' @param x_reactive (`reactive`)
123		#' returning vector of the same type as `x`. Is used to update
124		#' counts following the change in values of the filtered dataset.
125		#' If it is set to `reactive(NULL)` then counts based on filtered
126		#' dataset are not shown.
127		#' @param slice (`teal_slice`)
128		#' specification of this filter state.
129		#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
130		#' `get_state` returns `teal_slice` object which can be reused in other places.
131		#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
132		#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
133		#' @param extract_type (`character`)
134		#' specifying whether condition calls should be prefixed by `dataname`. Possible values:
135		#' - `character(0)` (default) `varname` in the condition call will not be prefixed
136		#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
137		#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
138		#'
139		#' @return Object of class `DateFilterState`, invisibly.
140		#'
141		initialize = function(x,
142		x_reactive = reactive(NULL),
143		slice,
144		extract_type = character(0)) {
145	24x	isolate({
146	24x	checkmate::assert_date(x)
147	23x	checkmate::assert_class(x_reactive, "reactive")
148
149	23x	super$initialize(
150	23x	x = x,
151	23x	x_reactive = x_reactive,
152	23x	slice = slice,
153	23x	extract_type = extract_type
154		)
155	23x	checkmate::assert_date(slice$choices, null.ok = TRUE)
156	22x	private$set_choices(slice$choices)
157	14x	if (is.null(slice$selected)) slice$selected <- slice$choices
158	22x	private$set_selected(slice$selected)
159		})
160
161	21x	invisible(self)
162		},
163
164		#' @description
165		#' Returns reproducible condition call for current selection.
166		#' For this class returned call looks like
167		#' `<varname> >= <min value> & <varname> <= <max value>` with optional `is.na(<varname>)`.
168		#' @param dataname (`character(1)`) containing possibly prefixed name of data set
169		#' @return `call` or `NULL`
170		#'
171		get_call = function(dataname) {
172	7x	if (isFALSE(private$is_any_filtered())) {
173	1x	return(NULL)
174		}
175	6x	choices <- as.character(private$get_selected())
176	6x	varname <- private$get_varname_prefixed(dataname)
177	6x	filter_call <-
178	6x	call(
179		"&",
180	6x	call(">=", varname, call("as.Date", choices[1L])),
181	6x	call("<=", varname, call("as.Date", choices[2L]))
182		)
183	6x	private$add_keep_na_call(filter_call, varname)
184		}
185		),
186
187		# private methods ----
188
189		private = list(
190		set_choices = function(choices) {
191	22x	if (is.null(choices)) {
192	19x	choices <- range(private$x, na.rm = TRUE)
193		} else {
194	3x	choices_adjusted <- c(
195	3x	max(choices[1L], min(private$x, na.rm = TRUE)),
196	3x	min(choices[2L], max(private$x, na.rm = TRUE))
197		)
198	3x	if (any(choices != choices_adjusted)) {
199	1x	warning(sprintf(
200	1x	"Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",
201	1x	private$get_varname(), private$get_dataname()
202		))
203	1x	choices <- choices_adjusted
204		}
205	3x	if (choices[1L] >= choices[2L]) {
206	1x	warning(sprintf(
207	1x	"Invalid choices: lower is higher / equal to upper, or not in range of variable values.
208	1x	Setting defaults. Varname: %s, dataname: %s.",
209	1x	private$get_varname(), private$get_dataname()
210		))
211	1x	choices <- range(private$x, na.rm = TRUE)
212		}
213		}
214	22x	private$set_is_choice_limited(private$x, choices)
215	22x	private$x <- private$x[(private$x >= choices[1L] & private$x <= choices[2L]) \| is.na(private$x)]
216	22x	private$teal_slice$choices <- choices
217	22x	invisible(NULL)
218		},
219
220		# @description
221		# Check whether the initial choices filter out some values of x and set the flag in case.
222		set_is_choice_limited = function(xl, choices) {
223	22x	private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) \| any(xl > choices[2L], na.rm = TRUE))
224	22x	invisible(NULL)
225		},
226		cast_and_validate = function(values) {
227	33x	tryCatch(
228	33x	expr = {
229	33x	values <- as.Date(values, origin = "1970-01-01")
230	!	if (anyNA(values)) stop()
231	30x	values
232		},
233	33x	error = function(e) stop("Vector of set values must contain values coercible to Date.")
234		)
235		},
236		check_length = function(values) {
237	1x	if (length(values) != 2) stop("Vector of set values must have length two.")
238	29x	if (values[1] > values[2]) {
239	1x	warning(
240	1x	sprintf(
241	1x	"Start date %s is set after the end date %s, the values will be replaced with a default date range.",
242	1x	values[1], values[2]
243		)
244		)
245	1x	values <- isolate(private$get_choices())
246		}
247	29x	values
248		},
249		remove_out_of_bounds_values = function(values) {
250	29x	choices <- private$get_choices()
251	29x	if (values[1] < choices[1L] \| values[1] > choices[2L]) {
252	5x	warning(
253	5x	sprintf(
254	5x	"Value: %s is outside of the possible range for column %s of dataset %s, setting minimum possible value.",
255	5x	values[1], private$get_varname(), private$get_dataname()
256		)
257		)
258	5x	values[1] <- choices[1L]
259		}
260
261	29x	if (values[2] > choices[2L] \| values[2] < choices[1L]) {
262	5x	warning(
263	5x	sprintf(
264	5x	"Value: %s is outside of the possible range for column %s of dataset %s, setting maximum possible value.",
265	5x	values[2], private$get_varname(), private$get_dataname()
266		)
267		)
268	5x	values[2] <- choices[2L]
269		}
270
271	29x	values
272		},
273
274		# shiny modules ----
275
276		# @description
277		# UI Module for `DateFilterState`.
278		# This UI element contains two date selections for `min` and `max`
279		# of the range and a checkbox whether to keep the `NA` values.
280		# @param id (`character(1)`) `shiny` module instance id.
281		ui_inputs = function(id) {
282	!	ns <- NS(id)
283	!	isolate({
284	!	tags$div(
285	!	tags$div(
286	!	class = "flex",
287	!	actionButton(
288	!	class = "date_reset_button",
289	!	inputId = ns("start_date_reset"),
290	!	label = NULL,
291	!	icon = icon("fas fa-undo")
292		),
293	!	tags$div(
294	!	class = "w-80 filter_datelike_input",
295	!	dateRangeInput(
296	!	inputId = ns("selection"),
297	!	label = NULL,
298	!	start = private$get_selected()[1],
299	!	end = private$get_selected()[2],
300	!	min = private$get_choices()[1L],
301	!	max = private$get_choices()[2L],
302	!	width = "100%"
303		)
304		),
305	!	actionButton(
306	!	class = "date_reset_button",
307	!	inputId = ns("end_date_reset"),
308	!	label = NULL,
309	!	icon = icon("fas fa-undo")
310		)
311		),
312	!	private$keep_na_ui(ns("keep_na"))
313		)
314		})
315		},
316
317		# @description
318		# Server module
319		# @param id (`character(1)`) `shiny` module instance id.
320		# @return `NULL`.
321		server_inputs = function(id) {
322	!	moduleServer(
323	!	id = id,
324	!	function(input, output, session) {
325	!	logger::log_debug("DateFilterState$server initializing, id: { private$get_id() }")
326
327		# this observer is needed in the situation when teal_slice$selected has been
328		# changed directly by the api - then it's needed to rerender UI element
329		# to show relevant values
330	!	private$session_bindings[[session$ns("selection_api")]] <- observeEvent(
331	!	ignoreNULL = TRUE, # dates needs to be selected
332	!	ignoreInit = TRUE,
333	!	eventExpr = private$get_selected(),
334	!	handlerExpr = {
335	!	if (!setequal(private$get_selected(), input$selection)) {
336	!	logger::log_debug("DateFilterState$server@1 state changed, id: { private$get_id() }")
337	!	updateDateRangeInput(
338	!	session = session,
339	!	inputId = "selection",
340	!	start = private$get_selected()[1],
341	!	end = private$get_selected()[2]
342		)
343		}
344		}
345		)
346
347	!	private$session_bindings[[session$ns("selection")]] <- observeEvent(
348	!	ignoreNULL = TRUE, # dates needs to be selected
349	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
350	!	eventExpr = input$selection,
351	!	handlerExpr = {
352	!	logger::log_debug("DateFilterState$server@2 selection changed, id: { private$get_id() }")
353	!	start_date <- input$selection[1]
354	!	end_date <- input$selection[2]
355
356	!	if (is.na(start_date) \|\| is.na(end_date) \|\| start_date > end_date) {
357	!	updateDateRangeInput(
358	!	session = session,
359	!	inputId = "selection",
360	!	start = private$get_selected()[1],
361	!	end = private$get_selected()[2]
362		)
363	!	showNotification(
364	!	"Start date must not be greater than the end date. Setting back to previous value.",
365	!	type = "warning"
366		)
367	!	return(NULL)
368		}
369
370	!	private$set_selected(c(start_date, end_date))
371		}
372		)
373
374
375	!	private$keep_na_srv("keep_na")
376
377	!	private$session_bindings[[session$ns("reset1")]] <- observeEvent(input$start_date_reset, {
378	!	logger::log_debug("DateFilterState$server@3 reset start date, id: { private$get_id() }")
379	!	updateDateRangeInput(
380	!	session = session,
381	!	inputId = "selection",
382	!	start = private$get_choices()[1L]
383		)
384		})
385
386	!	private$session_bindings[[session$ns("reset2")]] <- observeEvent(input$end_date_reset, {
387	!	logger::log_debug("DateFilterState$server@4 reset end date, id: { private$get_id() }")
388	!	updateDateRangeInput(
389	!	session = session,
390	!	inputId = "selection",
391	!	end = private$get_choices()[2L]
392		)
393		})
394
395	!	NULL
396		}
397		)
398		},
399		server_inputs_fixed = function(id) {
400	!	moduleServer(
401	!	id = id,
402	!	function(input, output, session) {
403	!	logger::log_debug("DateFilterState$server initializing, id: { private$get_id() }")
404
405	!	output$selection <- renderUI({
406	!	vals <- format(private$get_selected(), nsmall = 3)
407	!	tags$div(
408	!	tags$div(icon("calendar-days"), vals[1]),
409	!	tags$div(span(" - "), icon("calendar-days"), vals[2])
410		)
411		})
412
413	!	NULL
414		}
415		)
416		},
417
418		# @description
419		# Server module to display filter summary
420		# renders text describing selected date range and
421		# if NA are included also
422		content_summary = function(id) {
423	!	selected <- as.character(private$get_selected())
424	!	min <- selected[1]
425	!	max <- selected[2]
426	!	tagList(
427	!	tags$span(
428	!	class = "filter-card-summary-value",
429	!	HTML(min, "–", max)
430		),
431	!	tags$span(
432	!	class = "filter-card-summary-controls",
433	!	if (private$na_count > 0) {
434	!	tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
435		}
436		)
437		)
438		}
439		)
440		)

1		# EmptyFilterState ------
2
3		#' @name EmptyFilterState
4		#' @docType class
5		#'
6		#' @title `FilterState` object for empty variables
7		#'
8		#' @description `FilterState` subclass representing an empty variable.
9		#'
10		#' @examples
11		#' # use non-exported function from teal.slice
12		#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
13		#' EmptyFilterState <- getFromNamespace("EmptyFilterState", "teal.slice")
14		#'
15		#' library(shiny)
16		#'
17		#' filter_state <- EmptyFilterState$new(
18		#' x = NA,
19		#' slice = teal_slice(varname = "x", dataname = "data"),
20		#' extract_type = character(0)
21		#' )
22		#' isolate(filter_state$get_call())
23		#' filter_state$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
24		#' isolate(filter_state$get_call())
25		#'
26		#' @keywords internal
27		#'
28		EmptyFilterState <- R6::R6Class( # nolint
29		"EmptyFilterState",
30		inherit = FilterState,
31
32		# public methods ----
33		public = list(
34
35		#' @description
36		#' Initialize `EmptyFilterState` object.
37		#'
38		#' @param x (`vector`)
39		#' variable to be filtered,
40		#' @param x_reactive (`reactive`)
41		#' returning vector of the same type as `x`. Is used to update
42		#' counts following the change in values of the filtered dataset.
43		#' If it is set to `reactive(NULL)` then counts based on filtered
44		#' dataset are not shown.
45		#' @param slice (`teal_slice`)
46		#' specification of this filter state.
47		#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
48		#' `get_state` returns `teal_slice` object which can be reused in other places.
49		#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
50		#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
51		#' @param extract_type (`character`)
52		#' specifying whether condition calls should be prefixed by `dataname`. Possible values:
53		#' - `character(0)` (default) `varname` in the condition call will not be prefixed
54		#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
55		#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
56		#'
57		#' @return Object of class `EmptyFilterState`, invisibly.
58		#'
59		initialize = function(x,
60		x_reactive = reactive(NULL),
61		extract_type = character(0),
62		slice) {
63	6x	isolate({
64	6x	super$initialize(
65	6x	x = x,
66	6x	x_reactive = x_reactive,
67	6x	slice = slice,
68	6x	extract_type = extract_type
69		)
70	6x	private$set_choices(slice$choices)
71	6x	private$set_selected(slice$selected)
72		})
73
74	6x	invisible(self)
75		},
76
77		#' @description
78		#' Returns reproducible condition call for current selection relevant for selected variable type.
79		#' Uses internal reactive values, hence must be called in reactive or isolated context.
80		#' @param dataname name of data set; defaults to `private$get_dataname()`
81		#' @return `logical(1)`
82		#'
83		get_call = function(dataname) {
84	2x	if (isFALSE(private$is_any_filtered())) {
85	1x	return(NULL)
86		}
87	1x	if (missing(dataname)) dataname <- private$get_dataname()
88	1x	filter_call <- if (isTRUE(private$get_keep_na())) {
89	!	call("is.na", private$get_varname_prefixed(dataname))
90		} else {
91	1x	substitute(!is.na(varname), list(varname = private$get_varname_prefixed(dataname)))
92		}
93		}
94		),
95
96		# private members ----
97		private = list(
98		cache_state = function() {
99	!	private$cache <- private$get_state()
100	!	self$set_state(
101	!	list(
102	!	keep_na = NULL
103		)
104		)
105		},
106		set_choices = function(choices) {
107	6x	private$teal_slice$choices <- choices
108	6x	invisible(NULL)
109		},
110
111
112		# Reports whether the current state filters out any values.(?)
113		# @return `logical(1)`
114		#
115		is_any_filtered = function() {
116	2x	if (private$is_choice_limited) {
117	!	TRUE
118		} else {
119	2x	!isTRUE(private$get_keep_na())
120		}
121		},
122
123		# @description
124		# UI Module for `EmptyFilterState`.
125		# This UI element contains a checkbox input to filter or keep missing values.
126		# @param id (`character(1)`) `shiny` module instance id.
127		#
128		ui_inputs = function(id) {
129	!	ns <- NS(id)
130	!	isolate({
131	!	tags$div(
132	!	tags$span("Variable contains missing values only"),
133	!	private$keep_na_ui(ns("keep_na"))
134		)
135		})
136		},
137
138		# @description
139		# Controls state of the `keep_na` checkbox input.
140		#
141		# @param id (`character(1)`) `shiny` module instance id.
142		#
143		# @return `NULL`.
144		#
145		server_inputs = function(id) {
146	!	moduleServer(
147	!	id = id,
148	!	function(input, output, session) {
149	!	private$keep_na_srv("keep_na")
150		}
151		)
152		},
153		server_inputs_fixed = function(id) {
154	!	moduleServer(
155	!	id = id,
156	!	function(input, output, session) {
157	!	output$selection <- renderUI({
158	!	tags$span("Variable contains missing values only")
159		})
160	!	NULL
161		}
162		)
163		},
164
165		# @description
166		# Server module to display filter summary
167		# Doesn't render anything
168		content_summary = function(id) {
169	!	tags$span("All empty")
170		}
171		)
172		)

1		# DefaultFilteredDataset ----
2
3		#' @name DefaultFilteredDataset
4		#' @docType class
5		#' @title `DefaultFilteredDataset` `R6` class
6		#'
7		#' @description Stores any object as inert entity. Filtering is not supported.
8		#'
9		#' @examples
10		#' # use non-exported function from teal.slice
11		#' DefaultFilteredDataset <- getFromNamespace("DefaultFilteredDataset", "teal.slice")
12		#'
13		#' library(shiny)
14		#'
15		#' ds <- DefaultFilteredDataset$new(letters, "letters")
16		#' isolate(ds$get_filter_state())
17		#' isolate(ds$get_call())
18		#'
19		#' @keywords internal
20		#'
21		DefaultFilteredDataset <- R6::R6Class( # nolint
22		classname = "DefaultFilteredDataset",
23		inherit = FilteredDataset,
24
25		# public methods ----
26		public = list(
27
28		#' @description
29		#' Initializes this `DefaultFilteredDataset` object.
30		#'
31		#' @param dataset
32		#' any type of object; will not be filtered.
33		#' @param dataname (`character(1)`)
34		#' syntactically valid name given to the dataset.
35		#' @param label (`character(1)`)
36		#' label to describe the dataset.
37		#'
38		#' @return Object of class `DefaultFilteredDataset`, invisibly.
39		#'
40		initialize = function(dataset, dataname, label = character(0)) {
41	24x	super$initialize(dataset = dataset, dataname = dataname, label = label)
42		},
43
44		#' @description
45		#' Returns a formatted string representing this `DefaultFilteredDataset` object.
46		#'
47		#' @param show_all (`logical(1)`) for method consistency, ignored.
48		#' @param trim_lines (`logical(1)`) flag specifying whether to trim lines if class names are too long.
49		#'
50		#' @return The formatted string.
51		#'
52		format = function(show_all, trim_lines = FALSE) {
53	4x	class_string <- toString(class(private$dataset))
54	4x	if (trim_lines) {
55	2x	trim_position <- 37L
56	2x	class_string <- strtrim(class_string, trim_position)
57	2x	substr(class_string, 35L, 37L) <- "..."
58		}
59	4x	sprintf(" - unfiltered dataset:\t\"%s\": %s", private$dataname, class_string)
60		},
61
62		#' @param sid (`character(1)`) for method consistency, ignored.
63		#' @return `NULL`, invisibly.
64		get_call = function(sid) {
65	1x	invisible(NULL)
66		},
67		#' @return `NULL`, invisibly.
68		get_filter_state = function() {
69	2x	invisible(NULL)
70		},
71		#' @param state (`teal_slices`) for method consistency, ignored.
72		#' @return `NULL`, invisibly.
73		set_filter_state = function(state) {
74	3x	if (length(state) != 0L) {
75	1x	warning("DefaultFilterState cannot set state")
76		}
77	3x	invisible(NULL)
78		},
79		#' @param force (`logical(1)`) for method consistency, ignored.
80		#' @return `NULL`, invisibly.
81		clear_filter_states = function(force) {
82	1x	invisible(NULL)
83		},
84
85		#' @description
86		#' Creates row for filter overview in the form of \cr
87		#' `dataname` - unsupported data class
88		#' @return A `data.frame`.
89		get_filter_overview = function() {
90	1x	data.frame(dataname = private$dataname, obs = NA, obs_filtered = NA)
91		},
92
93		# shiny modules ----
94
95		#' @description
96		#' Overwrites parent method.
97		#' @details
98		#' Blank UI module that would list active filter states for this dataset.
99		#' @param id (`character(1)`)
100		#' `shiny` module instance id.
101		#' @param allow_add (ignored)
102		#' @return An empty `div`.
103		ui_active = function(id, allow_add) {
104	!	ns <- NS(id)
105	!	tags$div()
106		},
107
108		#' @description
109		#' Overwrites parent method.
110		#' @details
111		#' Blank UI module that would list active filter states for this dataset.
112		#' @param id (`character(1)`)
113		#' `shiny` module instance id.
114		#' @return An empty `div`.
115		ui_add = function(id) {
116	!	ns <- NS(id)
117	!	tags$div()
118		}
119		),
120		private = list(
121		# private methods ----
122		# private fields ----
123		)
124		)

1		#' Set "`<choice>:<label>`" type of names
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' This is often useful for as it marks up the drop-down boxes for [shiny::selectInput()].
6		#'
7		#' @details
8		#' If either `choices` or `labels` are factors, they are coerced to character.
9		#' Duplicated elements from `choices` get removed.
10		#'
11		#' @param choices (`character` or `numeric` or `logical`) vector
12		#' @param labels (`character`) vector containing labels to be applied to `choices`. If `NA` then
13		#' "Label Missing" will be used.
14		#' @param subset a vector that is a subset of `choices`. This is useful if
15		#' only a few variables need to be named. If this argument is used, the returned vector will
16		#' match its order.
17		#' @param types vector containing the types of the columns.
18		#'
19		#' @return A named character vector.
20		#'
21		#' @keywords internal
22		#'
23		choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
24	19x	if (is.factor(choices)) {
25	!	choices <- as.character(choices)
26		}
27
28	19x	stopifnot(
29	19x	is.character(choices) \|\|
30	19x	is.numeric(choices) \|\|
31	19x	is.logical(choices) \|\|
32	19x	(length(choices) == 1 && is.na(choices))
33		)
34
35	19x	if (is.factor(labels)) {
36	!	labels <- as.character(labels)
37		}
38
39	19x	checkmate::assert_character(labels[!is.na(labels)], any.missing = FALSE)
40	19x	if (length(choices) != length(labels)) {
41	!	stop("length of choices must be the same as labels")
42		}
43	19x	stopifnot(is.null(subset) \|\| is.vector(subset))
44	19x	stopifnot(is.null(types) \|\| is.vector(types))
45
46	19x	if (is.vector(types)) {
47	19x	stopifnot(length(choices) == length(types))
48		}
49
50	19x	if (!is.null(subset)) {
51	!	if (!all(subset %in% choices)) {
52	!	stop("all of subset variables must be in choices")
53		}
54	!	labels <- labels[choices %in% subset]
55	!	types <- types[choices %in% subset]
56	!	choices <- choices[choices %in% subset]
57		}
58
59	19x	is_dupl <- duplicated(choices)
60	19x	choices <- choices[!is_dupl]
61	19x	labels <- labels[!is_dupl]
62	19x	types <- types[!is_dupl]
63	19x	labels[is.na(labels)] <- "Label Missing"
64	19x	raw_labels <- labels
65	19x	combined_labels <- if (length(choices) > 0) {
66	19x	paste0(choices, ": ", labels)
67		} else {
68	!	character(0)
69		}
70
71	19x	if (!is.null(subset)) {
72	!	ord <- match(subset, choices)
73	!	choices <- choices[ord]
74	!	raw_labels <- raw_labels[ord]
75	!	combined_labels <- combined_labels[ord]
76	!	types <- types[ord]
77		}
78	19x	choices <- structure(
79	19x	choices,
80	19x	names = combined_labels,
81	19x	raw_labels = raw_labels,
82	19x	combined_labels = combined_labels,
83	19x	class = c("choices_labeled", "character"),
84	19x	types = types
85		)
86
87	19x	choices
88		}

1		#' Initialize `FilteredData`
2		#'
3		#' Function creates a `FilteredData` object.
4		#'
5		#' @param x (`named list`) of datasets.
6		#' @param join_keys (`join_keys`) see [`teal.data::join_keys()`].
7		#'
8		#' @return Object of class `FilteredData`.
9		#'
10		#' @examples
11		#' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars))
12		#' datasets
13		#'
14		#' @export
15		init_filtered_data <- function(x, join_keys = teal.data::join_keys()) { # nolint
16	7x	checkmate::assert_list(x, any.missing = FALSE, names = "unique")
17	6x	checkmate::assert_class(join_keys, "join_keys")
18	5x	FilteredData$new(x, join_keys = join_keys)
19		}
20
21		#' Evaluate expression with meaningful message
22		#'
23		#' Method created for the `FilteredData` object to execute filter call with
24		#' meaningful message. After evaluation used environment should contain
25		#' all necessary bindings.
26		#'
27		#' @param expr (`language`)
28		#' @param env (`environment`) where expression is evaluated.
29		#' @return `NULL`, invisibly.
30		#' @keywords internal
31		eval_expr_with_msg <- function(expr, env) {
32	32x	lapply(
33	32x	expr,
34	32x	function(x) {
35	19x	tryCatch(
36	19x	eval(x, envir = env),
37	19x	error = function(e) {
38	!	stop(
39	!	sprintf(
40	!	"Filter call execution failed:\n - call:\n %s\n - message:\n %s ",
41	!	deparse1(x, collapse = "\n"), e
42		)
43		)
44		}
45		)
46		}
47		)
48	32x	invisible(NULL)
49		}
50
51
52		#' Toggle button properties.
53		#'
54		#' Switch between different icons or titles on a button.
55		#'
56		#' Wrapper functions that use `shinyjs::runjs` to change button properties in response to events,
57		#' typically clicking those very buttons.
58		#' `shiny`'s `actionButton` and `actionLink` create `<a>` tags,
59		#' which may contain a child `<i>` tag that specifies an icon to be displayed.
60		#' `toggle_icon` calls the `toggleClass` (when `one_way = FALSE`) or
61		#' `removeClass` and `addClass` methods (when `one_way = TRUE`) to change icons.
62		#' `toggle_title` calls the `attr` method to modify the `Title` attribute of the button.
63		#'
64		#' @param input_id (`character(1)`) (name-spaced) id of the button
65		#' @param icons,titles (`character(2)`) vector specifying values between which to toggle
66		#' @param one_way (`logical(1)`) flag specifying whether to keep toggling;
67		#' if TRUE, the target will be changed
68		#' from the first element of `icons`/`titles` to the second
69		#'
70		#' @return `NULL`, invisibly.
71		#'
72		#' @examples
73		#' # use non-exported function from teal.slice
74		#' toggle_icon <- getFromNamespace("toggle_icon", "teal.slice")
75		#'
76		#' library(shiny)
77		#' library(shinyjs)
78		#'
79		#' ui <- fluidPage(
80		#' useShinyjs(),
81		#' actionButton("hide_content", label = "hide", icon = icon("xmark")),
82		#' actionButton("show_content", label = "show", icon = icon("check")),
83		#' actionButton("toggle_content", label = "toggle", icon = icon("angle-down")),
84		#' tags$br(),
85		#' tags$div(
86		#' id = "content",
87		#' verbatimTextOutput("printout")
88		#' )
89		#' )
90		#'
91		#' server <- function(input, output, session) {
92		#' observeEvent(input$hide_content,
93		#' {
94		#' hide("content")
95		#' toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE)
96		#' },
97		#' ignoreInit = TRUE
98		#' )
99		#'
100		#' observeEvent(input$show_content,
101		#' {
102		#' show("content")
103		#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE)
104		#' },
105		#' ignoreInit = TRUE
106		#' )
107		#'
108		#' observeEvent(input$toggle_content,
109		#' {
110		#' toggle("content")
111		#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"))
112		#' },
113		#' ignoreInit = TRUE
114		#' )
115		#'
116		#' output$printout <- renderPrint({
117		#' head(faithful, 10)
118		#' })
119		#' }
120		#' if (interactive()) {
121		#' shinyApp(ui, server)
122		#' }
123		#'
124		#' @name toggle_button
125		#' @rdname toggle_button
126		#' @keywords internal
127		toggle_icon <- function(input_id, icons, one_way = FALSE) {
128	3x	checkmate::assert_string(input_id)
129	3x	checkmate::assert_character(icons, len = 2L)
130	3x	checkmate::assert_flag(one_way)
131
132	3x	expr <-
133	3x	if (one_way) {
134	3x	sprintf(
135	3x	"$('#%s i').removeClass('%s').addClass('%s');",
136	3x	input_id, icons[1], icons[2]
137		)
138		} else {
139	!	sprintf("$('#%s i').toggleClass('%s');", input_id, paste(icons, collapse = " "))
140		}
141
142	3x	shinyjs::runjs(expr)
143
144	3x	invisible(NULL)
145		}
146
147		#' @rdname toggle_button
148		#' @keywords internal
149		toggle_title <- function(input_id, titles, one_way = FALSE) {
150	3x	checkmate::assert_string(input_id)
151	3x	checkmate::assert_character(titles, len = 2L)
152	3x	checkmate::assert_flag(one_way)
153
154	3x	expr <-
155	3x	if (one_way) {
156	3x	sprintf(
157	3x	"$('a#%s').attr('title', '%s');",
158	3x	input_id, titles[2]
159		)
160		} else {
161	!	sprintf(
162	!	paste0(
163	!	"var button_id = 'a#%1$s';",
164	!	"var curr = $(button_id).attr('title');",
165	!	"if (curr == '%2$s') { $(button_id).attr('title', '%3$s');",
166	!	"} else { $(button_id).attr('title', '%2$s');",
167		"}"
168		),
169	!	input_id, titles[1], titles[2]
170		)
171		}
172
173	3x	shinyjs::runjs(expr)
174
175	3x	invisible(NULL)
176		}
177
178		#' @inherit teal.data::topological_sort description details params title
179		#' @examples
180		#' # use non-exported function from teal.slice
181		#' topological_sort <- getFromNamespace("topological_sort", "teal.slice")
182		#'
183		#' topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
184		#' topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
185		#' topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
186		#' @keywords internal
187		topological_sort <- function(graph) {
188	64x	utils::getFromNamespace("topological_sort", ns = "teal.data")(graph)
189		}

1		# FilterPanelAPI ------
2
3		#' @name FilterPanelAPI
4		#' @docType class
5		#'
6		#' @title Class to encapsulate the API of the filter panel of a teal app
7		#'
8		#' @description
9		#' An API class for managing filter states in a teal application's filter panel.
10		#'
11		#' @details
12		#' The purpose of this class is to encapsulate the API of the filter panel in a
13		#' new class `FilterPanelAPI` so that it can be passed and used in the server
14		#' call of any module instead of passing the whole `FilteredData` object.
15		#'
16		#' This class is supported by methods to set, get, remove filter states in the
17		#' filter panel API.
18		#'
19		#' @examples
20		#' library(shiny)
21		#'
22		#' fd <- init_filtered_data(list(iris = iris))
23		#' fpa <- FilterPanelAPI$new(fd)
24		#'
25		#' # get the actual filter state --> empty named list
26		#' isolate(fpa$get_filter_state())
27		#'
28		#' # set a filter state
29		#' set_filter_state(
30		#' fpa,
31		#' teal_slices(
32		#' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)
33		#' )
34		#' )
35		#'
36		#' # get the actual filter state --> named list with filters
37		#' isolate(fpa$get_filter_state())
38		#'
39		#' # remove all_filter_states
40		#' fpa$clear_filter_states()
41		#'
42		#' # get the actual filter state --> empty named list
43		#' isolate(fpa$get_filter_state())
44		#'
45		#' @export
46		#'
47		FilterPanelAPI <- R6::R6Class( # nolint
48		"FilterPanelAPI",
49		# public methods ----
50		public = list(
51		#' @description
52		#' Initialize a `FilterPanelAPI` object.
53		#' @param datasets (`FilteredData`)
54		#'
55		initialize = function(datasets) {
56	8x	checkmate::assert_class(datasets, "FilteredData")
57	6x	private$filtered_data <- datasets
58		},
59
60		#' @description
61		#' Gets the reactive values from the active `FilterState` objects of the `FilteredData` object.
62		#'
63		#' Gets all active filters in the form of a nested list.
64		#' The output list is a compatible input to `set_filter_state`.
65		#'
66		#' @return `list` with named elements corresponding to `FilteredDataset` objects with active filters.
67		#'
68		get_filter_state = function() {
69	8x	private$filtered_data$get_filter_state()
70		},
71
72		#' @description
73		#' Sets active filter states.
74		#' @param filter (`teal_slices`)
75		#'
76		#' @return `NULL`, invisibly.
77		#'
78		set_filter_state = function(filter) {
79	5x	private$filtered_data$set_filter_state(filter)
80	5x	invisible(NULL)
81		},
82
83		#' @description
84		#' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object.
85		#'
86		#' @param filter (`teal_slices`)
87		#' specifying `FilterState` objects to remove;
88		#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored
89		#'
90		#' @return `NULL`, invisibly.
91		#'
92		remove_filter_state = function(filter) {
93	1x	private$filtered_data$remove_filter_state(filter)
94	1x	invisible(NULL)
95		},
96
97		#' @description
98		#' Remove all `FilterStates` of the `FilteredData` object.
99		#'
100		#' @param datanames (`character`)
101		#' `datanames` to remove their `FilterStates`;
102		#' omit to remove all `FilterStates` in the `FilteredData` object
103		#'
104		#' @return `NULL`, invisibly.
105		#'
106		clear_filter_states = function(datanames) {
107	2x	datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames
108	2x	private$filtered_data$clear_filter_states(datanames = datanames_to_remove)
109	2x	invisible(NULL)
110		}
111		),
112		# private methods ----
113		private = list(
114		filtered_data = NULL
115		)
116		)

1		#' Initialize `FilterStates` object
2		#'
3		#' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`)
4		#' object to subset.
5		#' @param data_reactive (`function(sid)`)
6		#' should return an object of the same type as `data` or `NULL`.
7		#' This function is needed for the `FilterState` `shiny` module to update counts if filtered data changes.
8		#' If function returns `NULL` then filtered counts are not shown.
9		#' Function has to have `sid` argument being a character which is related to `sid` argument in the `get_call` method.
10		#' @param dataname (`character(1)`)
11		#' name of the data used in the subset expression,
12		#' passed to the function argument attached to this `FilterStates`.
13		#' @param datalabel (`character(1)`) optional
14		#' text label.
15		#' @param ... optional,
16		#' additional arguments for specific classes: keys.
17		#'
18		#' @return Object of class `FilterStates`.
19		#'
20		#' @keywords internal
21		#' @examples
22		#' # use non-exported function from teal.slice
23		#' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
24		#'
25		#' df <- data.frame(
26		#' character = letters,
27		#' numeric = seq_along(letters),
28		#' date = seq(Sys.Date(), length.out = length(letters), by = "1 day"),
29		#' datetime = seq(Sys.time(), length.out = length(letters), by = "33.33 hours")
30		#' )
31		#' rf <- init_filter_states(
32		#' data = df,
33		#' dataname = "DF"
34		#' )
35		#'
36		#' library(shiny)
37		#' ui <- fluidPage(
38		#' actionButton("clear", tags$span(icon("xmark"), "Remove all filters")),
39		#' rf$ui_add(id = "add"),
40		#' rf$ui_active("states"),
41		#' verbatimTextOutput("expr"),
42		#' )
43		#'
44		#' server <- function(input, output, session) {
45		#' rf$srv_add(id = "add")
46		#' rf$srv_active(id = "states")
47		#' output$expr <- renderText({
48		#' deparse1(rf$get_call(), collapse = "\n")
49		#' })
50		#' observeEvent(input$clear, rf$clear_filter_states())
51		#' }
52		#'
53		#' if (interactive()) {
54		#' shinyApp(ui, server)
55		#' }
56		#'
57		#' @export
58		#'
59		init_filter_states <- function(data,
60		data_reactive = reactive(NULL),
61		dataname,
62		datalabel = NULL,
63		...) {
64	213x	UseMethod("init_filter_states")
65		}
66
67		#' @keywords internal
68		#' @export
69		init_filter_states.data.frame <- function(data, # nolint
70		data_reactive = function(sid = "") NULL,
71		dataname,
72		datalabel = NULL,
73		keys = character(0),
74		...) {
75	96x	DFFilterStates$new(
76	96x	data = data,
77	96x	data_reactive = data_reactive,
78	96x	dataname = dataname,
79	96x	datalabel = datalabel,
80	96x	keys = keys
81		)
82		}
83
84		#' @keywords internal
85		#' @export
86		init_filter_states.matrix <- function(data, # nolint
87		data_reactive = function(sid = "") NULL,
88		dataname,
89		datalabel = NULL,
90		...) {
91	20x	MatrixFilterStates$new(
92	20x	data = data,
93	20x	data_reactive = data_reactive,
94	20x	dataname = dataname,
95	20x	datalabel = datalabel
96		)
97		}
98
99		#' @keywords internal
100		#' @export
101		init_filter_states.MultiAssayExperiment <- function(data, # nolint
102		data_reactive = function(sid = "") NULL,
103		dataname,
104		datalabel = "subjects",
105		keys = character(0),
106		...) {
107	20x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
108	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
109		}
110	20x	MAEFilterStates$new(
111	20x	data = data,
112	20x	data_reactive = data_reactive,
113	20x	dataname = dataname,
114	20x	datalabel = datalabel,
115	20x	keys = keys
116		)
117		}
118
119		#' @keywords internal
120		#' @export
121		init_filter_states.SummarizedExperiment <- function(data, # nolint
122		data_reactive = function(sid = "") NULL,
123		dataname,
124		datalabel = NULL,
125		...) {
126	77x	if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
127	!	stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
128		}
129	77x	SEFilterStates$new(
130	77x	data = data,
131	77x	data_reactive = data_reactive,
132	77x	dataname = dataname,
133	77x	datalabel = datalabel
134		)
135		}
136
137		#' Gets supported filterable variable names
138		#'
139		#' Gets filterable variable names from a given object. The names match variables
140		#' of classes in an vector `teal.slice:::.filterable_class`.
141		#' @param data
142		#' the `R` object containing elements which class can be checked through `vapply` or `apply`.
143		#' @return `character` vector of variable names.
144		#' @examples
145		#' # use non-exported function from teal.slice
146		#' get_supported_filter_varnames <- getFromNamespace("get_supported_filter_varnames", "teal.slice")
147		#'
148		#' df <- data.frame(
149		#' a = letters[1:3],
150		#' b = 1:3,
151		#' c = Sys.Date() + 1:3,
152		#' d = Sys.time() + 1:3,
153		#' z = complex(3)
154		#' )
155		#' get_supported_filter_varnames(df)
156		#' @keywords internal
157		#' @export
158		get_supported_filter_varnames <- function(data) {
159	227x	UseMethod("get_supported_filter_varnames")
160		}
161
162		#' @keywords internal
163		#' @export
164		get_supported_filter_varnames.default <- function(data) { # nolint
165	200x	is_expected_class <- vapply(
166	200x	X = data,
167	200x	FUN = function(x) any(class(x) %in% .filterable_class),
168	200x	FUN.VALUE = logical(1)
169		)
170	200x	names(is_expected_class[is_expected_class])
171		}
172
173		#' @keywords internal
174		#' @export
175		get_supported_filter_varnames.matrix <- function(data) { # nolint
176		# all columns are the same type in matrix
177	27x	is_expected_class <- class(data[, 1]) %in% .filterable_class
178	27x	if (is_expected_class && !is.null(colnames(data))) {
179	24x	colnames(data)
180		} else {
181	3x	character(0)
182		}
183		}
184
185		#' @keywords internal
186		#' @export
187		get_supported_filter_varnames.MultiAssayExperiment <- function(data) { # nolint
188	!	data <- SummarizedExperiment::colData(data)
189		# all columns are the same type in matrix
190	!	is_expected_class <- class(data[, 1]) %in% .filterable_class
191	!	if (is_expected_class && !is.null(names(data))) {
192	!	names(data)
193		} else {
194	!	character(0)
195		}
196		}
197
198		#' Returns a `choices_labeled` object
199		#'
200		#' @param data (`data.frame` or `DFrame` or `list`)
201		#' where labels can be taken from in case when `varlabels` is not specified.
202		#' `data` must be specified if `varlabels` is not specified.
203		#' @param choices (`character`)
204		#' the vector of chosen variables
205		#' @param varlabels (`character`)
206		#' the labels of variables in data
207		#' @param keys (`character`)
208		#' the names of the key columns in data
209		#' @return `character(0)` if choices are empty; a `choices_labeled` object otherwise
210		#' @keywords internal
211		data_choices_labeled <- function(data,
212		choices,
213		varlabels = teal.data::col_labels(data, fill = TRUE),
214		keys = character(0)) {
215	25x	if (length(choices) == 0) {
216	6x	return(character(0))
217		}
218	19x	choice_types <- variable_types(data = data, columns = choices)
219	19x	choice_types[keys] <- "primary_key"
220
221	19x	choices_labeled(
222	19x	choices = choices,
223	19x	labels = unname(varlabels[choices]),
224	19x	types = choice_types[choices]
225		)
226		}
227
228		#' @noRd
229		#' @keywords internal
230		get_varlabels <- function(data) {
231	17x	if (!is.array(data)) {
232	16x	vapply(
233	16x	colnames(data),
234	16x	FUN = function(x) {
235	120x	label <- attr(data[[x]], "label")
236	120x	if (is.null(label)) {
237	118x	x
238		} else {
239	2x	label
240		}
241		},
242	16x	FUN.VALUE = character(1)
243		)
244		} else {
245	1x	character(0)
246		}
247		}

1		# MAEFilterStates ------
2
3		#' @name MAEFilterStates
4		#' @docType class
5		#' @title `FilterStates` subclass for `MultiAssayExperiment`s
6		#' @description Handles filter states in a `MultiAssayExperiment`.
7		#' @keywords internal
8		#'
9		MAEFilterStates <- R6::R6Class( # nolint
10		classname = "MAEFilterStates",
11		inherit = FilterStates,
12		# public methods ----
13		public = list(
14		#' @description
15		#' Initialize `MAEFilterStates` object.
16		#'
17		#' @param data (`MultiAssayExperiment`)
18		#' the `R` object which `MultiAssayExperiment::subsetByColData` function is applied on.
19		#' @param data_reactive (`function(sid)`)
20		#' should return a `MultiAssayExperiment` object or `NULL`.
21		#' This object is needed for the `FilterState` counts being updated
22		#' on a change in filters. If function returns `NULL` then filtered counts are not shown.
23		#' Function has to have `sid` argument being a character.
24		#' @param dataname (`character(1)`)
25		#' name of the data used in the subset expression.
26		#' Passed to the function argument attached to this `FilterStates`.
27		#' @param datalabel (`character(1)`) optional
28		#' text label.
29		#' @param varlabels (`character`)
30		#' labels of the variables used in this object.
31		#' @param keys (`character`)
32		#' key column names.
33		#'
34		initialize = function(data,
35		data_reactive = function(sid = "") NULL,
36		dataname,
37		datalabel = "subjects",
38		keys = character(0)) {
39	24x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
40	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
41		}
42	24x	checkmate::assert_function(data_reactive, args = "sid")
43	24x	checkmate::assert_class(data, "MultiAssayExperiment")
44
45	23x	data <- SummarizedExperiment::colData(data)
46	23x	data_reactive <- function(sid = "") SummarizedExperiment::colData(data_reactive(sid = sid))
47	23x	super$initialize(data, data_reactive, dataname, datalabel)
48	23x	private$keys <- keys
49	23x	private$set_filterable_varnames(include_varnames = colnames(data))
50
51	23x	invisible(self)
52		}
53		),
54
55		# private fields ----
56
57		private = list(
58		extract_type = "list",
59		fun = quote(MultiAssayExperiment::subsetByColData)
60		)
61		)

1		#' Include `CSS` files from `/inst/css/` package directory to application header
2		#'
3		#' `system.file` should not be used to access files in other packages, it does
4		#' not work with `devtools`. Therefore, we redefine this method in each package
5		#' as needed. Thus, we do not export this method.
6		#'
7		#' @param pattern (`character`) pattern of files to be included
8		#'
9		#' @return HTML code that includes `CSS` files
10		#' @keywords internal
11		include_css_files <- function(pattern = "*") {
12	!	css_files <- list.files(
13	!	system.file("css", package = "teal.slice", mustWork = TRUE),
14	!	pattern = pattern, full.names = TRUE
15		)
16	!	singleton(tags$head(lapply(css_files, includeCSS)))
17		}

1		# This file contains helper functions used in unit tests.
2
3		# compares specified fields between two `teal_slice` objects
4		#' @noRd
5		#' @keywords internal
6		compare_slices <- function(ts1, ts2, fields) {
7	9x	isolate(
8	9x	all(vapply(fields, function(x) identical(ts1[[x]], ts2[[x]]), logical(1L)))
9		)
10		}
11
12
13		# compare two teal_slice
14		#' @noRd
15		#' @keywords internal
16		expect_identical_slice <- function(x, y) {
17	34x	isolate({
18	34x	testthat::expect_true(
19	34x	setequal(
20	34x	reactiveValuesToList(x),
21	34x	reactiveValuesToList(y)
22		)
23		)
24		})
25		}
26
27		# compare two teal_slices
28		#' @noRd
29		#' @keywords internal
30		expect_identical_slices <- function(x, y) {
31	12x	isolate({
32	12x	mapply(
33	12x	function(x, y) {
34	27x	expect_identical_slice(x, y)
35		},
36	12x	x = x,
37	12x	y = y
38		)
39	12x	testthat::expect_identical(attributes(x), attributes(y))
40		})
41		}

1		#' Managing `FilteredData` states
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' Set, get and remove filter states of `FilteredData` object.
6		#'
7		#' @name filter_state_api
8		#'
9		#' @param datasets (`FilteredData`)
10		#' object to store filter state and filtered datasets, shared across modules
11		#'
12		#' see [`FilteredData`] for details
13		#'
14		#' @param filter (`teal_slices`)
15		#' specify filters in place on app start-up
16		#'
17		#' @param force (`logical(1)`)
18		#' flag specifying whether to include anchored filter states.
19		#'
20		#' @return
21		#' - `set_`, `remove_` and `clear_filter_state` return `NULL` invisibly
22		#' - `get_filter_state` returns a named `teal_slices` object
23		#' containing a `teal_slice` for every existing `FilterState`
24		#'
25		#' @seealso [`teal_slice`]
26		#'
27		#' @examples
28		#' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars))
29		#' fs <- teal_slices(
30		#' teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor")),
31		#' teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)),
32		#' teal_slice(dataname = "mtcars", varname = "gear", selected = c(4, 5)),
33		#' teal_slice(dataname = "mtcars", varname = "carb", selected = c(4, 10))
34		#' )
35		#'
36		#' # set initial filter state
37		#' set_filter_state(datasets, filter = fs)
38		#'
39		#' # get filter state
40		#' get_filter_state(datasets)
41		#'
42		#' # modify filter state
43		#' set_filter_state(
44		#' datasets,
45		#' teal_slices(
46		#' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)
47		#' )
48		#' )
49		#'
50		#' # remove specific filters
51		#' remove_filter_state(
52		#' datasets,
53		#' teal_slices(
54		#' teal_slice(dataname = "iris", varname = "Species"),
55		#' teal_slice(dataname = "mtcars", varname = "gear"),
56		#' teal_slice(dataname = "mtcars", varname = "carb")
57		#' )
58		#' )
59		#'
60		#' # remove all states
61		#' clear_filter_states(datasets)
62		#'
63		#' @examples
64		#' \donttest{
65		#' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
66		#' # Requires MultiAssayExperiment from Bioconductor
67		#' data(miniACC, package = "MultiAssayExperiment")
68		#'
69		#' datasets <- init_filtered_data(list(mae = miniACC))
70		#' fs <- teal_slices(
71		#' teal_slice(
72		#' dataname = "mae", varname = "years_to_birth", selected = c(30, 50),
73		#' keep_na = TRUE, keep_inf = FALSE
74		#' ),
75		#' teal_slice(
76		#' dataname = "mae", varname = "vital_status", selected = "1",
77		#' keep_na = FALSE
78		#' ),
79		#' teal_slice(
80		#' dataname = "mae", varname = "gender", selected = "female",
81		#' keep_na = TRUE
82		#' ),
83		#' teal_slice(
84		#' dataname = "mae", varname = "ARRAY_TYPE", selected = "",
85		#' keep_na = TRUE, experiment = "RPPAArray", arg = "subset"
86		#' )
87		#' )
88		#'
89		#' # set initial filter state
90		#' set_filter_state(datasets, filter = fs)
91		#'
92		#' # get filter state
93		#' get_filter_state(datasets)
94		#'
95		#' # modify filter state
96		#' set_filter_state(
97		#' datasets,
98		#' teal_slices(
99		#' teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(40, 60))
100		#' )
101		#' )
102		#'
103		#' # remove specific filters
104		#' remove_filter_state(
105		#' datasets,
106		#' teal_slices(
107		#' teal_slice(dataname = "mae", varname = "years_to_birth"),
108		#' teal_slice(dataname = "mae", varname = "vital_status")
109		#' )
110		#' )
111		#'
112		#' # remove all states
113		#' clear_filter_states(datasets)
114		#' }
115		#' }
116		NULL
117
118		#' @rdname filter_state_api
119		#' @export
120		set_filter_state <- function(datasets, filter) {
121	3x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
122	3x	checkmate::assert_class(filter, "teal_slices")
123	3x	datasets$set_filter_state(filter)
124	3x	invisible(NULL)
125		}
126
127		#' @rdname filter_state_api
128		#' @export
129		get_filter_state <- function(datasets) {
130	4x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
131	4x	if (isRunning()) {
132	!	datasets$get_filter_state()
133		} else {
134	4x	isolate(datasets$get_filter_state())
135		}
136		}
137
138		#' @rdname filter_state_api
139		#' @export
140		remove_filter_state <- function(datasets, filter) {
141	1x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
142	1x	checkmate::assert_class(filter, "teal_slices")
143
144	1x	datasets$remove_filter_state(filter)
145	1x	invisible(NULL)
146		}
147
148		#' @rdname filter_state_api
149		#' @export
150		clear_filter_states <- function(datasets, force = FALSE) {
151	1x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
152	1x	datasets$clear_filter_states(force = force)
153	1x	invisible(NULL)
154		}
155
156		#' Gets filter expression for multiple `datanames` taking into account its order.
157		#'
158		#' @description `r lifecycle::badge("stable")`
159		#'
160		#' To be used in `Show R Code` button.
161		#'
162		#' @param datasets (`FilteredData`)
163		#' @param datanames (`character`) vector of dataset names
164		#'
165		#' @return A character string containing all subset expressions.
166		#'
167		#' @export
168		#'
169		get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
170	2x	checkmate::check_class(datasets, "FilteredData")
171	2x	checkmate::assert_character(datanames, any.missing = FALSE)
172	2x	checkmate::assert_subset(datanames, datasets$datanames())
173	2x	paste(
174	2x	unlist(lapply(
175	2x	datanames,
176	2x	function(dataname) {
177	4x	datasets$get_call(dataname)
178		}
179		)),
180	2x	collapse = "\n"
181		)
182		}

1		# DFFilterStates ------
2
3		#' @name DFFilterStates
4		#' @docType class
5		#'
6		#' @title `FilterStates` subclass for data frames
7		#'
8		#' @description Handles filter states in a `data.frame`.
9		#'
10		#' @examples
11		#' # use non-exported function from teal.slice
12		#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
13		#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
14		#' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
15		#'
16		#' library(shiny)
17		#' library(shinyjs)
18		#'
19		#' # create data frame to filter
20		#' data_df <- data.frame(
21		#' NUM1 = 1:100,
22		#' NUM2 = round(runif(100, min = 20, max = 23)),
23		#' CHAR1 = sample(LETTERS[1:6], size = 100, replace = TRUE),
24		#' CHAR2 = sample(c("M", "F"), size = 100, replace = TRUE),
25		#' DATE = seq(as.Date("2020-01-01"), by = 1, length.out = 100),
26		#' DATETIME = as.POSIXct(seq(as.Date("2020-01-01"), by = 1, length.out = 100))
27		#' )
28		#' data_na <- data.frame(
29		#' NUM1 = NA,
30		#' NUM2 = NA,
31		#' CHAR1 = NA,
32		#' CHAR2 = NA,
33		#' DATE = NA,
34		#' DATETIME = NA
35		#' )
36		#' data_df <- rbind(data_df, data_na)
37		#'
38		#' # initiate `FilterStates` object
39		#' filter_states_df <- init_filter_states(
40		#' data = data_df,
41		#' dataname = "dataset",
42		#' datalabel = ("label")
43		#' )
44		#'
45		#' ui <- fluidPage(
46		#' useShinyjs(),
47		#' include_css_files(pattern = "filter-panel"),
48		#' include_js_files(pattern = "count-bar-labels"),
49		#' column(4, tags$div(
50		#' tags$h4("Active filters"),
51		#' filter_states_df$ui_active("fsdf")
52		#' )),
53		#' column(4, tags$div(
54		#' tags$h4("Manual filter control"),
55		#' filter_states_df$ui_add("add_filters"), tags$br(),
56		#' tags$h4("Condition (i.e. call)"), # display the subset expression generated by this FilterStates
57		#' textOutput("call_df"), tags$br(),
58		#' tags$h4("Formatted state"), # display human readable filter state
59		#' textOutput("formatted_df"), tags$br()
60		#' )),
61		#' column(4, tags$div(
62		#' tags$h4("Programmatic filter control"),
63		#' actionButton("button1_df", "set NUM1 < 30", width = "100%"), tags$br(),
64		#' actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), tags$br(),
65		#' actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"), tags$br(),
66		#' actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), tags$br(),
67		#' actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), tags$br(),
68		#' actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), tags$br(),
69		#' tags$hr(),
70		#' actionButton("button7_df", "remove NUM1", width = "100%"), tags$br(),
71		#' actionButton("button8_df", "remove NUM2", width = "100%"), tags$br(),
72		#' actionButton("button9_df", "remove CHAR1", width = "100%"), tags$br(),
73		#' actionButton("button10_df", "remove CHAR2", width = "100%"), tags$br(),
74		#' actionButton("button11_df", "remove DATE", width = "100%"), tags$br(),
75		#' actionButton("button12_df", "remove DATETIME", width = "100%"), tags$br(),
76		#' tags$hr(),
77		#' actionButton("button0_df", "clear all filters", width = "100%"), tags$br()
78		#' ))
79		#' )
80		#'
81		#' server <- function(input, output, session) {
82		#' filter_states_df$srv_add("add_filters")
83		#' filter_states_df$srv_active("fsdf")
84		#'
85		#' output$call_df <- renderPrint(filter_states_df$get_call())
86		#' output$formatted_df <- renderText(filter_states_df$format())
87		#'
88		#' observeEvent(input$button1_df, {
89		#' filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30)))
90		#' filter_states_df$set_filter_state(state = filter_state)
91		#' })
92		#' observeEvent(input$button2_df, {
93		#' filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21)))
94		#' filter_states_df$set_filter_state(state = filter_state)
95		#' })
96		#' observeEvent(input$button3_df, {
97		#' filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D")))
98		#' filter_states_df$set_filter_state(state = filter_state)
99		#' })
100		#' observeEvent(input$button4_df, {
101		#' filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F")))
102		#' filter_states_df$set_filter_state(state = filter_state)
103		#' })
104		#' observeEvent(input$button5_df, {
105		#' filter_state <- teal_slices(
106		#' teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02"))
107		#' )
108		#' filter_states_df$set_filter_state(state = filter_state)
109		#' })
110		#' observeEvent(input$button6_df, {
111		#' filter_state <- teal_slices(
112		#' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
113		#' )
114		#' filter_states_df$set_filter_state(state = filter_state)
115		#' })
116		#'
117		#' observeEvent(input$button7_df, {
118		#' filter_state <- teal_slices(teal_slice("dataset", "NUM1"))
119		#' filter_states_df$remove_filter_state(filter_state)
120		#' })
121		#' observeEvent(input$button8_df, {
122		#' filter_state <- teal_slices(teal_slice("dataset", "NUM2"))
123		#' filter_states_df$remove_filter_state(filter_state)
124		#' })
125		#' observeEvent(input$button9_df, {
126		#' filter_state <- teal_slices(teal_slice("dataset", "CHAR1"))
127		#' filter_states_df$remove_filter_state(filter_state)
128		#' })
129		#' observeEvent(input$button10_df, {
130		#' filter_state <- teal_slices(teal_slice("dataset", "CHAR2"))
131		#' filter_states_df$remove_filter_state(filter_state)
132		#' })
133		#' observeEvent(input$button11_df, {
134		#' filter_state <- teal_slices(
135		#' teal_slice("dataset", "DATE")
136		#' )
137		#' filter_states_df$remove_filter_state(filter_state)
138		#' })
139		#' observeEvent(input$button12_df, {
140		#' filter_state <- teal_slices(
141		#' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
142		#' )
143		#' filter_states_df$remove_filter_state(filter_state)
144		#' })
145		#'
146		#' observeEvent(input$button0_df, filter_states_df$clear_filter_states())
147		#' }
148		#'
149		#' if (interactive()) {
150		#' shinyApp(ui, server)
151		#' }
152		#' @keywords internal
153		#'
154		DFFilterStates <- R6::R6Class( # nolint
155		classname = "DFFilterStates",
156		inherit = FilterStates,
157
158		# public methods ----
159		public = list(
160		#' @description
161		#' Initializes `DFFilterStates` object by setting `dataname`
162		#' and initializing `state_list` (`shiny::reactiveVal`).
163		#' This class contains a single `state_list` with no specified name,
164		#' which means that when calling the subset function associated with this class
165		#' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`).
166		#'
167		#' @param data (`data.frame`)
168		#' the `R` object which `dplyr::filter` function will be applied on.
169		#' @param data_reactive (`function(sid)`)
170		#' should return a `data.frame` object or `NULL`.
171		#' This object is needed for the `FilterState` counts being updated on a change in filters.
172		#' If function returns `NULL` then filtered counts are not shown.
173		#' Function has to have `sid` argument being a character.
174		#' @param dataname (`character`)
175		#' name of the data used in the subset expression.
176		#' Passed to the function argument attached to this `FilterStates`.
177		#' @param datalabel (`character(1)`) optional
178		#' text label.
179		#' @param keys (`character`)
180		#' key column names.
181		#'
182		initialize = function(data,
183		data_reactive = function(sid = "") NULL,
184		dataname,
185		datalabel = NULL,
186		keys = character(0)) {
187	99x	checkmate::assert_function(data_reactive, args = "sid")
188	99x	checkmate::assert_data_frame(data)
189	99x	super$initialize(data, data_reactive, dataname, datalabel)
190	99x	private$keys <- keys
191	99x	private$set_filterable_varnames(include_varnames = colnames(private$data))
192		}
193		),
194
195		# private members ----
196		private = list(
197		fun = quote(dplyr::filter)
198		)
199		)

1		#' Initialize `FilteredDataset`
2		#'
3		#' Initializes a `FilteredDataset` object corresponding to the class of the filtered dataset.
4		#'
5		#' @param dataset any object
6		#' @param dataname (`character(1)`)
7		#' syntactically valid name given to the dataset.
8		#' @param keys (`character`) optional
9		#' vector of primary key column names.
10		#' @param parent_name (`character(1)`)
11		#' name of the parent dataset.
12		#' @param parent (`reactive`)
13		#' that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`.
14		#' Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset`
15		#' based on the changes in `parent`.
16		#' @param join_keys (`character`)
17		#' vector of names of columns in this dataset to join with `parent` dataset.
18		#' If column names in the parent do not match these, they should be given as the names of this vector.
19		#' @param label (`character(1)`)
20		#' label to describe the dataset.
21		#'
22		#' @return Object of class `FilteredDataset`.
23		#'
24		#' @section Warning:
25		#' This function is exported to allow other packages to extend `teal.slice` but it is treated as internal.
26		#' Breaking changes may occur without warning.
27		#' We recommend consulting the package maintainer before using it.
28		#'
29		#' @examples
30		#' # DataframeFilteredDataset example
31		#' library(shiny)
32		#'
33		#' iris_fd <- init_filtered_dataset(iris, dataname = "iris")
34		#' ui <- fluidPage(
35		#' iris_fd$ui_add(id = "add"),
36		#' iris_fd$ui_active("dataset"),
37		#' verbatimTextOutput("call")
38		#' )
39		#' server <- function(input, output, session) {
40		#' iris_fd$srv_add(id = "add")
41		#' iris_fd$srv_active(id = "dataset")
42		#'
43		#' output$call <- renderText({
44		#' paste(
45		#' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),
46		#' collapse = "\n"
47		#' )
48		#' })
49		#' }
50		#' if (interactive()) {
51		#' shinyApp(ui, server)
52		#' }
53		#'
54		#' @examples
55		#' \donttest{
56		#' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
57		#' # MAEFilteredDataset example
58		#' library(shiny)
59		#'
60		#' data(miniACC, package = "MultiAssayExperiment")
61		#'
62		#' MAE_fd <- init_filtered_dataset(miniACC, "MAE")
63		#' ui <- fluidPage(
64		#' MAE_fd$ui_add(id = "add"),
65		#' MAE_fd$ui_active("dataset"),
66		#' verbatimTextOutput("call")
67		#' )
68		#' server <- function(input, output, session) {
69		#' MAE_fd$srv_add(id = "add")
70		#' MAE_fd$srv_active(id = "dataset")
71		#' output$call <- renderText({
72		#' paste(
73		#' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),
74		#' collapse = "\n"
75		#' )
76		#' })
77		#' }
78		#' if (interactive()) {
79		#' shinyApp(ui, server)
80		#' }
81		#' }
82		#' }
83		#' @keywords internal
84		#' @export
85		init_filtered_dataset <- function(dataset,
86		dataname,
87		keys = character(0),
88		parent_name = character(0),
89		parent = reactive(dataset),
90		join_keys = character(0),
91		label = attr(dataset, "label", exact = TRUE)) {
92	101x	UseMethod("init_filtered_dataset")
93		}
94
95		#' @keywords internal
96		#' @export
97		init_filtered_dataset.data.frame <- function(dataset,
98		dataname,
99		keys = character(0),
100		parent_name = character(0),
101		parent = NULL,
102		join_keys = character(0),
103		label = attr(dataset, "label", exact = TRUE)) {
104	79x	DataframeFilteredDataset$new(
105	79x	dataset = dataset,
106	79x	dataname = dataname,
107	79x	keys = keys,
108	79x	parent_name = parent_name,
109	79x	parent = parent,
110	79x	join_keys = join_keys,
111	79x	label = label
112		)
113		}
114
115		#' @keywords internal
116		#' @export
117		init_filtered_dataset.MultiAssayExperiment <- function(dataset,
118		dataname,
119		keys = character(0),
120		parent_name, # ignored
121		parent, # ignored
122		join_keys, # ignored
123		label = attr(dataset, "label", exact = TRUE)) {
124	5x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
125	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
126		}
127	5x	MAEFilteredDataset$new(
128	5x	dataset = dataset,
129	5x	dataname = dataname,
130	5x	keys = keys,
131	5x	label = label
132		)
133		}
134
135		#' @keywords internal
136		#' @export
137		init_filtered_dataset.default <- function(dataset,
138		dataname,
139		keys, # ignored
140		parent_name, # ignored
141		parent, # ignored
142		join_keys, # ignored
143		label = attr(dataset, "label", exact = TRUE)) {
144	17x	DefaultFilteredDataset$new(
145	17x	dataset = dataset,
146	17x	dataname = dataname,
147	17x	label = label
148		)
149		}

1		# MatrixFilterStates ------
2
3		#' @name MatrixFilterStates
4		#' @docType class
5		#' @title `FilterStates` subclass for matrices
6		#' @description Handles filter states in a `matrix`.
7		#' @keywords internal
8		#'
9		MatrixFilterStates <- R6::R6Class( # nolint
10		classname = "MatrixFilterStates",
11		inherit = FilterStates,
12
13		# public methods ----
14		public = list(
15		#' @description
16		#' Initialize `MatrixFilterStates` object.
17		#'
18		#' @param data (`matrix`)
19		#' the `R` object which `subset` function is applied on.
20		#' @param data_reactive (`function(sid)`)
21		#' should return a `matrix` object or `NULL`.
22		#' This object is needed for the `FilterState` counts being updated on a change in filters.
23		#' If function returns `NULL` then filtered counts are not shown.
24		#' Function has to have `sid` argument being a character.
25		#' @param dataname (`character(1)`)
26		#' name of the data used in the subset expression.
27		#' Passed to the function argument attached to this `FilterStates`.
28		#' @param datalabel (`character(1)`) optional
29		#' text label. Should be a name of experiment.
30		#'
31		initialize = function(data,
32		data_reactive = function(sid = "") NULL,
33		dataname,
34		datalabel = NULL) {
35	24x	checkmate::assert_matrix(data)
36	23x	super$initialize(data, data_reactive, dataname, datalabel)
37	23x	private$set_filterable_varnames(include_varnames = colnames(private$data))
38	23x	if (!is.null(datalabel)) {
39	19x	private$dataname_prefixed <- sprintf(
40	19x	"%s[['%s']]", private$dataname_prefixed, datalabel
41		)
42		}
43		}
44		),
45		private = list(
46		extract_type = "matrix"
47		)
48		)