teal.slice coverage - 66.10%

Files
Source

# 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"))
#' )
#' isolate(datasets$get_call("iris"))
#'
#' 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_trace("FilteredData$set_dataset setting dataset, name: { dataname }")
      # to include it nicely in the Show R Code;
      # the UI also uses `datanames` in ids, so no whitespaces allowed
      check_simple_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_trace("{ 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)
        })

        logger::log_trace("{ class(self)[1] }$set_filter_state initialized")
      })

      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")
        datanames <- unique(vapply(state, "[[", character(1L), "dataname"))
        checkmate::assert_subset(datanames, self$datanames())

        logger::log_trace(
          "{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }"
        )

        lapply(datanames, function(dataname) {
          slices <- Filter(function(x) identical(x$dataname, dataname), state)
          private$get_filtered_dataset(dataname)$remove_filter_state(slices)
        })

        logger::log_trace(
          "{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }"
        )
      })

      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_trace(
        "FilteredData$clear_filter_states called, datanames: { toString(datanames) }"
      )

      for (dataname in datanames) {
        fdataset <- private$get_filtered_dataset(dataname = dataname)
        fdataset$clear_filter_states(force)
      }

      logger::log_trace(
        paste(
          "FilteredData$clear_filter_states removed all non-anchored FilterStates,",
          "datanames: { toString(datanames) }"
        )
      )

      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.
    #' @return `shiny.tag`
    ui_filter_panel = function(id) {
      ns <- NS(id)
      div(
        id = ns(NULL), # used for hiding / showing
        include_css_files(pattern = "filter-panel"),
        self$ui_overview(ns("overview")),
        self$ui_active(ns("active")),
        if (private$allow_add) {
          self$ui_add(ns("add"))
        }
      )
    },

    #' @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_trace("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)
          if (private$allow_add) {
            self$srv_add("add", active_datanames_resolved)
          }

          logger::log_trace("FilteredData$srv_filter_panel initialized")
          NULL
        }
      )
    },

    #' @description
    #' Server module responsible for displaying active filters.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `shiny.tag`
    ui_active = function(id) {
      ns <- NS(id)
      div(
        id = id, # not used, can be used to customize CSS behavior
        class = "well",
        tags$div(
          class = "filter-panel-active-header",
          tags$span("Active Filter Variables", class = "text-primary mb-4"),
          private$ui_available_filters(ns("available_filters")),
          actionLink(
            inputId = ns("minimise_filter_active"),
            label = NULL,
            icon = icon("angle-down", lib = "font-awesome"),
            title = "Minimise panel",
            class = "remove_all pull-right"
          ),
          actionLink(
            inputId = ns("remove_all_filters"),
            label = "",
            icon("circle-xmark", lib = "font-awesome"),
            title = "Remove active filters",
            class = "remove_all pull-right"
          )
        ),
        div(
          id = ns("filter_active_vars_contents"),
          tagList(
            lapply(
              self$datanames(),
              function(dataname) {
                fdataset <- private$get_filtered_dataset(dataname)
                fdataset$ui_active(id = ns(dataname))
              }
            )
          )
        ),
        shinyjs::hidden(
          div(
            id = ns("filters_active_count"),
            textOutput(ns("teal_filters_count"))
          )
        )
      )
    },

    #' @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_trace("FilteredData$srv_active initializing")

        private$srv_available_filters("available_filters")

        observeEvent(input$minimise_filter_active, {
          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"))
        })

        observeEvent(private$get_filter_count(), {
          shinyjs::toggle("remove_all_filters", condition = private$get_filter_count() != 0)
          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)
        })

        observeEvent(active_datanames(), {
          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 <- private$get_filter_count()
          req(n_filters_active > 0L)
          sprintf(
            "%s filter%s applied across datasets",
            n_filters_active,
            ifelse(n_filters_active == 1, "", "s")
          )
        })

        observeEvent(input$remove_all_filters, {
          logger::log_trace("FilteredData$srv_filter_panel@1 removing all non-anchored filters")
          self$clear_filter_states()
          logger::log_trace("FilteredData$srv_filter_panel@1 removed all non-anchored filters")
        })
        logger::log_trace("FilteredData$srv_active initialized")
        NULL
      })
    },

    #' @description
    #' Server module responsible for displaying drop-downs with variables to add a filter.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `shiny.tag`
    ui_add = function(id) {
      ns <- NS(id)
      div(
        id = id, # not used, can be used to customize CSS behavior
        class = "well",
        tags$div(
          class = "row",
          tags$div(
            class = "col-sm-9",
            tags$label("Add Filter Variables", class = "text-primary mb-4")
          ),
          tags$div(
            class = "col-sm-3",
            actionLink(
              ns("minimise_filter_add_vars"),
              label = NULL,
              icon = icon("angle-down", lib = "font-awesome"),
              title = "Minimise panel",
              class = "remove pull-right"
            )
          )
        ),
        div(
          id = ns("filter_add_vars_contents"),
          tagList(
            lapply(
              self$datanames(),
              function(dataname) {
                fdataset <- private$get_filtered_dataset(dataname)
                span(id = ns(dataname), fdataset$ui_add(ns(dataname)))
              }
            )
          )
        )
      )
    },

    #' @description
    #' Server module responsible for displaying drop-downs with variables to add a filter.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param active_datanames (`reactive`)
    #'   defining subset of `self$datanames()` to be displayed.
    #' @return `NULL`.
    srv_add = function(id, active_datanames = reactive(self$datanames())) {
      checkmate::assert_class(active_datanames, "reactive")
      moduleServer(id, function(input, output, session) {
        logger::log_trace("FilteredData$srv_add initializing")
        observeEvent(input$minimise_filter_add_vars, {
          shinyjs::toggle("filter_add_vars_contents")
          toggle_icon(session$ns("minimise_filter_add_vars"), c("fa-angle-right", "fa-angle-down"))
          toggle_title(session$ns("minimise_filter_add_vars"), c("Restore panel", "Minimise Panel"))
        })

        observeEvent(active_datanames(), {
          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_add(id = dataname)
          }
        )
        logger::log_trace("FilteredData$srv_filter_panel initialized")
        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)
      div(
        id = id, # not used, can be used to customize CSS behavior
        class = "well",
        tags$div(
          class = "row",
          tags$div(
            class = "col-sm-9",
            tags$label("Active Filter Summary", class = "text-primary mb-4")
          ),
          tags$div(
            class = "col-sm-3",
            actionLink(
              ns("minimise_filter_overview"),
              label = NULL,
              icon = icon("angle-down", lib = "font-awesome"),
              title = "Minimise panel",
              class = "remove pull-right"
            )
          )
        ),
        div(
          id = ns("filters_overview_contents"),
          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_trace("FilteredData$srv_filter_overview initializing")

          observeEvent(input$minimise_filter_overview, {
            shinyjs::toggle("filters_overview_contents")
            toggle_icon(session$ns("minimise_filter_overview"), c("fa-angle-right", "fa-angle-down"))
            toggle_title(session$ns("minimise_filter_overview"), c("Restore panel", "Minimise Panel"))
          })

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

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

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


            if (!is.null(datasets_df$subjects)) {
              # some datasets (without keys) doesn't return subjects
              datasets_df <- transform(
                datasets_df,
                Subjects = ifelse(
                  !is.na(subjects),
                  sprintf("%s/%s", subjects_filtered, subjects),
                  ""
                )
              )
            }
            datasets_df <- datasets_df[, colnames(datasets_df) %in% c("dataname", "Obs", "Subjects")]

            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_html <- tags$tr(
              tagList(
                lapply(colnames(datasets_df), tags$td)
              )
            )

            table_html <- tags$table(
              class = "table custom-table",
              tags$thead(header_html),
              tags$tbody(body_html)
            )
            logger::log_trace("FilteredData$srv_filter_overview@1 updated counts")
            table_html
          })
          logger::log_trace("FilteredData$srv_filter_overview initialized")
          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,

    # 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]]
      }
    },

    # we implement these functions as checks rather than returning logicals so they can
    # give informative error messages immediately

    # @description
    # Gets the number of active `FilterState` objects in all `FilterStates`
    # in all `FilteredDataset`s in this `FilteredData` object.
    # @return `integer(1)`
    get_filter_count = function() {
      length(self$get_filter_state())
    },

    # @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"))
      div(
        id = ns("available_menu"),
        shinyWidgets::dropMenu(
          actionLink(
            ns("show"),
            label = NULL,
            icon = icon("plus", lib = "font-awesome"),
            title = "Available filters",
            class = "remove pull-right"
          ),
          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,
            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
          )
        })

        observeEvent(input$available_slices_id, ignoreNULL = FALSE, ignoreInit = TRUE, {
          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)
          }
        })

        observeEvent(private$available_teal_slices(), ignoreNULL = FALSE, {
          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, div(
#'     h4("RangeFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, div(
#'     id = "outputs", # div id is needed for toggling the element
#'     h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_range"), br(),
#'     h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_range"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_range"), br()
#'   )),
#'   column(4, div(
#'     h4("Programmatic filter control"),
#'     actionButton("button1_range", "set drop NA", width = "100%"), br(),
#'     actionButton("button2_range", "set keep NA", width = "100%"), br(),
#'     actionButton("button3_range", "set drop Inf", width = "100%"), br(),
#'     actionButton("button4_range", "set keep Inf", width = "100%"), br(),
#'     actionButton("button5_range", "set a range", width = "100%"), br(),
#'     actionButton("button6_range", "set full range", width = "100%"), br(),
#'     actionButton("button0_range", "set initial state", width = "100%"), 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(
          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");
                    }
                  });
                });'
              )
            )),
            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
          ),
          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_trace("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"))

          # 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()))
            histogram
          })

          # Dragging shapes (lines) on plot updates selection.
          private$observers$relayout <-
            observeEvent(
              ignoreNULL = FALSE,
              ignoreInit = TRUE,
              eventExpr = plotly::event_data("plotly_relayout", source = session$ns("histogram_plot")),
              handlerExpr = {
                logger::log_trace("RangeFilterState$server@1 selection changed, id: { private$get_id() }")
                event <- plotly::event_data("plotly_relayout", source = session$ns("histogram_plot"))
                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$observers$selection_api <-
            observeEvent(
              ignoreNULL = FALSE,
              ignoreInit = TRUE,
              eventExpr = private$get_selected(),
              handlerExpr = {
                logger::log_trace("RangeFilterState$server@2 state changed, id: {private$get_id() }")
                if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) {
                  shinyWidgets::updateNumericRangeInput(
                    session = session,
                    inputId = "selection_manual",
                    value = private$get_selected()
                  )
                }
              }
            )

          # Manual input updates selection.
          private$observers$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_trace("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")

          logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
          NULL
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("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
            )
          })

          logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
          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())
        )
        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$observers$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_trace("RangeFilterState$keep_inf_srv@1 changed reactive value, id: { private$get_id() }")
              updateCheckboxInput(
                inputId = "value",
                value = private$get_keep_inf()
              )
            }
          }
        )

        private$observers$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_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
            keep_inf <- input$value
            private$set_keep_inf(keep_inf)
          }
        )

        invisible(NULL)
      })
    }
  )
)

# FilterStates ------

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

  # public members ----
  public = list(
    #' @description
    #' Initializes `FilterStates` object by setting
    #' `dataname`, and `datalabel`.
    #'
    #' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`)
    #'   the `R` object which `subset` function is applied on.
    #' @param data_reactive (`function(sid)`)
    #'   should return an object of the same type as `data` object or `NULL`.
    #'   This object is needed for the `FilterState` counts being updated
    #'   on a change in filters. If function returns `NULL` then filtered counts are not shown.
    #'   Function has to have `sid` argument being a character.
    #' @param dataname (`character(1)`)
    #'   name of the dataset, used in the subset expression.
    #'   Passed to the function argument attached to this `FilterStates`.
    #' @param datalabel (`character(1)`)
    #'   optional text label.
    #'
    #' @return
    #' Object of class `FilterStates`, invisibly.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL) {
      checkmate::assert_string(dataname)
      logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
      checkmate::assert_function(data_reactive, args = "sid")
      checkmate::assert_string(datalabel, null.ok = TRUE)

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

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

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

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

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

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

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

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

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

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

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

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

      fs
    },

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

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

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

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

      invisible(NULL)
    },

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

    # shiny modules ----

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

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

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

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

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

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

          NULL
        }
      )
    },

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

      ns <- NS(id)

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

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

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

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


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

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

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

    # private methods ----

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

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

    # state_list methods ----

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

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

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

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

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

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

      invisible(NULL)
    },

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

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

      invisible(NULL)
    },

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

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

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

      invisible(NULL)
    }
  )
)

# 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_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(x) {
          checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname")
        })

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

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

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


        logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
      })

      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)

      div(
        tags$label("Add", tags$code(self$get_dataname()), "filter"),
        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)
    }
  )
)

# 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']]", dataname, 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_trace("{ class(self)[1] }$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)
            }
          }
        )

        logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
        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) {
        div("no sample variables available")
      } else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
        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) {
        div("no sample variables available")
      } else if (nrow(SummarizedExperiment::colData(data)) == 0) {
        div("no samples available")
      } else {
        teal.widgets::optionalSelectInput(
          ns("col_to_add"),
          choices = NULL,
          options = shinyWidgets::pickerOptions(
            liveSearch = TRUE,
            noneSelectedText = "Select sample variable"
          )
        )
      }

      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_trace("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
            )
          })

          observeEvent(
            avail_row_data_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_trace(paste(
                "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()
              )
              logger::log_trace(paste(
                "SEFilterStates$srv_add@1 updated available row data choices,",
                "dataname: { private$dataname }"
              ))
            }
          )

          observeEvent(
            avail_col_data_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_trace(paste(
                "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()
              )
              logger::log_trace(paste(
                "SEFilterStates$srv_add@2 updated available col data choices,",
                "dataname: { private$dataname }"
              ))
            }
          )

          observeEvent(
            eventExpr = input$col_to_add,
            handlerExpr = {
              logger::log_trace(
                sprintf(
                  "SEFilterStates$srv_add@3 adding FilterState of column %s to col data, dataname: %s",
                  deparse1(input$col_to_add),
                  private$dataname
                )
              )
              varname <- input$col_to_add
              self$set_filter_state(teal_slices(
                teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select")
              ))

              logger::log_trace(
                sprintf(
                  "SEFilterStates$srv_add@3 added FilterState of column %s to col data, dataname: %s",
                  deparse1(varname),
                  private$dataname
                )
              )
            }
          )


          observeEvent(
            eventExpr = input$row_to_add,
            handlerExpr = {
              logger::log_trace(
                sprintf(
                  "SEFilterStates$srv_add@4 adding FilterState of variable %s to row data, dataname: %s",
                  deparse1(input$row_to_add),
                  private$dataname
                )
              )
              varname <- input$row_to_add
              self$set_filter_state(teal_slices(
                teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset")
              ))

              logger::log_trace(
                sprintf(
                  "SEFilterStates$srv_add@4 added FilterState of variable %s to row data, dataname: %s",
                  deparse1(varname),
                  private$dataname
                )
              )
            }
          )

          logger::log_trace("SEFilterState$srv_add initialized, dataname: { private$dataname }")
          NULL
        }
      )
    }
  )
)

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

# 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, div(
#'     h4("LogicalFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, div(
#'     id = "outputs", # div id is needed for toggling the element
#'     h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_logical"), br(),
#'     h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_logical"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_logical"), br()
#'   )),
#'   column(4, div(
#'     h4("Programmatic filter control"),
#'     actionButton("button1_logical", "set drop NA", width = "100%"), br(),
#'     actionButton("button2_logical", "set keep NA", width = "100%"), br(),
#'     actionButton("button3_logical", "set a selection", width = "100%"), br(),
#'     actionButton("button0_logical", "set initial state", width = "100%"), 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%"
          )
        }
        div(
          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_trace("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$observers$seleted_api <- observeEvent(
            ignoreNULL = !private$is_multiple(),
            ignoreInit = TRUE,
            eventExpr = private$get_selected(),
            handlerExpr = {
              if (!setequal(private$get_selected(), input$selection)) {
                logger::log_trace("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$observers$selection <- observeEvent(
            ignoreNULL = FALSE,
            ignoreInit = TRUE,
            eventExpr = input$selection,
            handlerExpr = {
              logger::log_trace("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")

          logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
          NULL
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("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]
            )
          })

          logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
          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_trace("filtering data dataname: { dataname }, sid: { sid }")
          } else {
            logger::log_trace("filtering data dataname: { private$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)) {
        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 = "") {
      logger::log_trace("DataframeFilteredDataset$get_call initializing for dataname: { private$dataname }")
      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)
      }
      logger::log_trace("DataframeFilteredDataset$get_call initializing for dataname: { private$dataname }")
      filter_call
    },

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #' @return `NULL`, invisibly.
    #'
    set_filter_state = function(state) {
      isolate({
        logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(slice) {
          checkmate::assert_true(slice$dataname == 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_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")

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

        logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
      })

      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$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_trace("FilteredDataset$srv_filter_overview initialized")
      # 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)
  )
)

#' 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)
#'
#' @examplesIf requireNamespace("MultiAssayExperiment")
#'
#' # 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::assert_character(datanames, min.len = 1, any.missing = FALSE)
  stopifnot(
    is(datasets, "FilteredData"),
    all(datanames %in% datasets$datanames())
  )

  paste(
    unlist(lapply(
      datanames,
      function(dataname) {
        datasets$get_call(dataname)
      }
    )),
    collapse = "\n"
  )
}

# 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)) {
      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"))
      }

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

      logger::log_trace("Instantiated FilterState object id: { private$get_id() }")

      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) {
      checkmate::assert_class(state, "teal_slice")
      if (private$is_fixed()) {
        logger::log_warn("attempt to set state on fixed filter aborted id: { private$get_id() }")
      } else {
        logger::log_trace("{ class(self)[1] }$set_state setting state of filter id: { private$get_id() }")
        isolate({
          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.
    #'
    #' @return Reactive expression signaling that remove button has been clicked.
    #'
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilterState$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$observers$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$observers$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$observers$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$observers$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$destroy_shiny <- function() {
            logger::log_trace("Destroying FilterState inputs and observers; id: { private$get_id() }")
            # remove values from the input list
            lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)

            # remove observers
            lapply(private$observers, function(x) x$destroy())
          }

          reactive(input$remove)
        }
      )
    },

    #' @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.

      div(
        id = id,
        class = "panel filter-card",
        include_js_files("count-bar-labels.js"),
        div(
          class = "filter-card-header",
          `data-toggle` = "collapse",
          `data-bs-toggle` = "collapse",
          href = paste0("#", ns("body")),
          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")
            },
            div(class = "filter-card-varname", strong(private$get_varname())),
            div(class = "filter-card-varlabel", private$get_varlabel()),
            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("circle-arrow-left", lib = "font-awesome"),
                  title = "Rewind state",
                  class = "filter-card-back",
                  style = "display: none"
                )
              },
              if (isFALSE(private$is_fixed())) {
                actionLink(
                  inputId = ns("reset"),
                  label = NULL,
                  icon = icon("circle-arrow-up", lib = "font-awesome"),
                  title = "Restore original state",
                  class = "filter-card-back",
                  style = "display: none"
                )
              },
              if (isFALSE(private$is_anchored())) {
                actionLink(
                  inputId = ns("remove"),
                  label = icon("circle-xmark", lib = "font-awesome"),
                  title = "Remove filter",
                  class = "filter-card-remove"
                )
              }
            )
          ),
          div(class = "filter-card-summary", private$ui_summary(ns("summary")))
        ),
        div(
          id = ns("body"),
          class = "collapse out",
          `data-parent` = paste0("#", parent_id),
          `data-bs-parent` = paste0("#", parent_id),
          div(
            class = "filter-card-body",
            if (private$is_fixed()) {
              private$ui_inputs_fixed(ns("inputs"))
            } else {
              private$ui_inputs(ns("inputs"))
            }
          )
        )
      )
    },

    #' @description
    #' Destroy observers stored in `private$observers`.
    #'
    #' @return `NULL`, invisibly.
    #'
    destroy_observers = function() {
      if (!is.null(private$destroy_shiny)) {
        private$destroy_shiny()
      }
    }
  ),

  # 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
    destroy_shiny = NULL, # function is set in server
    # other
    is_choice_limited = FALSE, # flag whether number of possible choices was limited when specifying filter
    observers = list(), # stores observers
    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) {
      logger::log_trace(
        sprintf(
          "%s$set_selected setting selection of id: %s",
          class(self)[1],
          private$get_id()
        )
      )
      isolate({
        value <- private$cast_and_validate(value)
        value <- private$check_length(value)
        value <- private$remove_out_of_bounds_values(value)
        private$teal_slice$selected <- value
      })
      logger::log_trace(
        sprintf(
          "%s$set_selected selection of id: %s",
          class(self)[1],
          private$get_id()
        )
      )

      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) {
      checkmate::assert_flag(value)
      private$teal_slice$keep_na <- value
      logger::log_trace(
        sprintf(
          "%s$set_keep_na set for filter %s to %s.",
          class(self)[1],
          private$get_id(),
          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) {
      checkmate::assert_flag(value)
      private$teal_slice$keep_inf <- value
      logger::log_trace(
        sprintf(
          "%s$set_keep_inf of filter %s set to %s",
          class(self)[1],
          private$get_id(),
          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)
      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 = span(
              id = ns("count_label"),
              make_count_text(
                label = "Keep NA",
                countmax = countmax,
                countnow = countnow
              )
            ),
            value = private$get_keep_na()
          )
          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$observers$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_trace("FilterState$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$observers$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_trace("FilterState$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)
      })
    }
  )
)

#' 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
}

# 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, div(
#'     h4("DateFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, div(
#'     id = "outputs", # div id is needed for toggling the element
#'     h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_date"), br(),
#'     h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_date"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_date"), br()
#'   )),
#'   column(4, div(
#'     h4("Programmatic filter control"),
#'     actionButton("button1_date", "set drop NA", width = "100%"), br(),
#'     actionButton("button2_date", "set keep NA", width = "100%"), br(),
#'     actionButton("button3_date", "set a range", width = "100%"), br(),
#'     actionButton("button4_date", "set full range", width = "100%"), br(),
#'     actionButton("button0_date", "set initial state", width = "100%"), 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)), min(choices[2L], max(private$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(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({
        div(
          div(
            class = "flex",
            actionButton(
              class = "date_reset_button",
              inputId = ns("start_date_reset"),
              label = NULL,
              icon = icon("fas fa-undo")
            ),
            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_trace("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$observers$seletion_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_trace("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$observers$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_trace("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$observers$reset1 <- observeEvent(input$start_date_reset, {
            logger::log_trace("DateFilterState$server@3 reset start date, id: { private$get_id() }")
            updateDateRangeInput(
              session = session,
              inputId = "selection",
              start = private$get_choices()[1L]
            )
          })

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

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

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

          logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
          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"))
          }
        )
      )
    }
  )
)

# 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, div(
#'     h4("DatetimeFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, div(
#'     id = "outputs", # div id is needed for toggling the element
#'     h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_datetime"), br(),
#'     h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_datetime"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_datetime"), br()
#'   )),
#'   column(4, div(
#'     h4("Programmatic filter control"),
#'     actionButton("button1_datetime", "set drop NA", width = "100%"), br(),
#'     actionButton("button2_datetime", "set keep NA", width = "100%"), br(),
#'     actionButton("button3_datetime", "set a range", width = "100%"), br(),
#'     actionButton("button4_datetime", "set full range", width = "100%"), br(),
#'     actionButton("button0_datetime", "set initial state", width = "100%"), 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"))

        div(
          div(
            class = "flex",
            ui_reset_1,
            div(
              class = "flex w-80 filter_datelike_input",
              div(class = "w-45 text-center", ui_input_1),
              span(
                class = "input-group-addon w-10",
                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"
              ),
              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_trace("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$observers$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_trace("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$observers$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_trace("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$observers$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_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
            }
          )

          private$keep_na_srv("keep_na")

          private$observers$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_trace("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
            }
          )
          private$observers$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_trace("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
            }
          )

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

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

          logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
          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"))
          }
        )
      )
    }
  )
)

#' Test whether variable name can be used within `Show R Code`
#'
#' Variable names containing spaces are problematic and must be wrapped in backticks.
#' Also, they should not start with a number as `R` may silently make it valid by changing it.
#' Therefore, we only allow alphanumeric characters with underscores.
#' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters.
#'
#' @md
#'
#' @param name (`character`) vector of names to check
#' @return Returns `NULL` or raises error.
#' @keywords internal
#'
check_simple_name <- function(name) {
  checkmate::assert_character(name, min.len = 1, any.missing = FALSE)
  if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
    stop(
      "name '",
      name,
      "' must only contain alphanumeric characters (with underscores)",
      " and the first character must be an alphabetic character"
    )
  }
}

#' 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`
#' @param except (`character`) vector of basename filenames to be excluded
#'
#' @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
  )
  return(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
  }
}

# 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))
    }
  ),
  private = list(
    extract_type = "matrix"
  )
)

# 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, div(
#'     h4("ChoicesFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, div(
#'     h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_choices"), br(),
#'     h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_choices"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_choices"), br()
#'   )),
#'   column(4, div(
#'     h4("Programmatic filter control"),
#'     actionButton("button1_choices", "set drop NA", width = "100%"), br(),
#'     actionButton("button2_choices", "set keep NA", width = "100%"), br(),
#'     actionButton("button3_choices", "set selection: a, b", width = "100%"), br(),
#'     actionButton("button4_choices", "deselect all", width = "100%"), br(),
#'     actionButton("button0_choices", "set initial state", width = "100%"), 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"
        )

        x_factor <- if (!is.factor(x)) {
          structure(
            factor(as.character(x), levels = as.character(sort(unique(x)))),
            label = attr(x, "label")
          )
        } else {
          x
        }

        super$initialize(
          x = x_factor,
          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)
        private$data_class <- class(x)[1L]
        if (inherits(x, "POSIXt")) {
          private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))
        }

        private$set_choices_counts(unname(table(x_factor)))
      })
      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)
      selected <- private$get_selected()
      if (length(selected) == 0) {
        choices <- private$get_choices()
        fun_compare <- if (length(choices) == 1L) "==" else "%in%"
        filter_call <- call("!", call(fun_compare, varname, make_c_call(as.character(choices))))
      } else {
        if (setequal(na.omit(private$x), selected)) {
          filter_call <- NULL
        } else {
          fun_compare <- if (length(selected) == 1L) "==" else "%in%"

          if (private$data_class != "factor") {
            selected <- do.call(sprintf("as.%s", private$data_class), list(x = selected))
          }

          filter_call <-
            if (inherits(selected, "Date")) {
              call(fun_compare, varname, call("as.Date", make_c_call(as.character(selected))))
            } else if (inherits(selected, c("POSIXct", "POSIXlt"))) {
              class <- class(selected)[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 {
              # 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),
    data_class = character(0), # stores class of filtered variable so that it can be restored in $get_call
    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) {
      if (is.null(choices)) {
        choices <- levels(private$x)
      } else {
        choices <- as.character(choices)
        choices_adjusted <- choices[choices %in% levels(private$x)]
        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 <- levels(private$x)
        }
      }
      private$set_is_choice_limited(private$x, choices)
      private$teal_slice$choices <- choices
      private$x <- private$x[(private$x %in% private$get_choices()) | is.na(private$x)]
      private$x <- droplevels(private$x)
      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 how many counts of each choice is present in the data.
    get_choices_counts = function() {
      if (!is.null(private$x_reactive)) {
        table(factor(private$x_reactive(), levels = private$get_choices()))
      } else {
        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 rettrigger renderUI
      isolate({
        countsmax <- private$choices_counts
        countsnow <- if (!is.null(private$x_reactive())) {
          unname(table(factor(private$x_reactive(), levels = private$get_choices())))
        }

        ui_input <- if (private$is_checkboxgroup()) {
          labels <- countBars(
            inputId = ns("labels"),
            choices = private$get_choices(),
            countsnow = countsnow,
            countsmax = countsmax
          )
          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"
            )
          )
        }
        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_trace("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_trace("ChoicesFilterState$server_inputs@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())))
            }

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

          if (private$is_checkboxgroup()) {
            private$observers$selection <- 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_trace("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 {
            private$observers$selection <- 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_trace("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$observers$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_trace("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()
                )
              }
            }
          })

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

          output$selection <- renderUI({
            countsnow <- if (!is.null(private$x_reactive())) {
              unname(table(factor(private$x_reactive(), levels = private$get_choices())))
            }
            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]
            )
          })

          logger::log_trace("ChoicesFilterState$server_inputs_fixed initialized, id: { private$get_id() }")
          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"))
          }
        )
      )
    }
  )
)

# 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")) {
      logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")

      # dataset assertion in child classes
      check_simple_name(dataname)
      checkmate::assert_character(keys, any.missing = FALSE)
      checkmate::assert_character(label, null.ok = TRUE)

      logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
      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_trace("filtering data dataname: { dataname }, sid: { sid }")
        } else {
          logger::log_trace("filtering data dataname: { private$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())
      logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
      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_trace("Removing filters from FilteredDataset: { deparse1(self$get_dataname()) }")
      lapply(
        private$get_filter_states(),
        function(filter_states) filter_states$clear_filter_states(force)
      )
      logger::log_trace("Removed filters from FilteredDataset: { deparse1(self$get_dataname()) }")
      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 number of `FilterState` objects in all `FilterStates` in this `FilteredDataset`.
    #' @return `integer(1)`
    get_filter_count = function() {
      length(self$get_filter_state())
    },

    #' @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.
    #'
    #' @return `shiny.tag`
    ui_active = function(id) {
      dataname <- self$get_dataname()
      checkmate::assert_string(dataname)

      ns <- NS(id)
      if_multiple_filter_states <- length(private$get_filter_states()) > 1
      span(
        id = id,
        include_css_files("filter-panel"),
        div(
          id = ns("whole_ui"), # to hide it entirely
          fluidRow(
            column(
              width = 8,
              tags$span(dataname, class = "filter_panel_dataname")
            ),
            column(
              width = 4,
              tagList(
                actionLink(
                  ns("remove_filters"),
                  label = "",
                  icon = icon("circle-xmark", lib = "font-awesome"),
                  class = "remove pull-right"
                ),
                actionLink(
                  ns("collapse"),
                  label = "",
                  icon = icon("angle-down", lib = "font-awesome"),
                  class = "remove pull-right"
                )
              )
            )
          ),
          shinyjs::hidden(
            div(
              id = ns("filter_count_ui"),
              tagList(
                textOutput(ns("filter_count")),
                br()
              )
            )
          ),
          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)))
                }
              )
            )
          )
        )
      )
    },

    #' @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_trace("FilteredDataset$srv_active initializing, dataname: { dataname }")
          checkmate::assert_string(dataname)
          output$filter_count <- renderText(
            sprintf(
              "%d filter%s applied",
              self$get_filter_count(),
              if (self$get_filter_count() != 1) "s" else ""
            )
          )

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

          observeEvent(self$get_filter_state(), {
            shinyjs::hide("filter_count_ui")
            shinyjs::show("filters")
            shinyjs::toggle("remove_filters", condition = length(self$get_filter_state()) != 0)
            shinyjs::toggle("collapse", condition = length(self$get_filter_state()) != 0)
          })

          observeEvent(input$collapse, {
            shinyjs::toggle("filter_count_ui")
            shinyjs::toggle("filters")
            toggle_icon(session$ns("collapse"), c("fa-angle-right", "fa-angle-down"))
          })

          observeEvent(input$remove_filters, {
            logger::log_trace("FilteredDataset$srv_active@1 removing all non-anchored filters, dataname: { dataname }")
            self$clear_filter_states()
            logger::log_trace("FilteredDataset$srv_active@1 removed all non-anchored filters, dataname: { dataname }")
          })

          logger::log_trace("FilteredDataset$initialized, dataname: { 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_trace("MAEFilteredDataset$srv_add initializing, dataname: { deparse1(self$get_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)
          )
          logger::log_trace("MAEFilteredDataset$srv_add initialized, dataname: { deparse1(self$get_dataname()) }")
          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),

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

#' 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(
#'   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
  )
}

#' Specify single filter
#'
#' Create a `teal_slice` object that holds complete information on filtering one variable.
#'
#' `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 (optional `vector`) specifying 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 (optional `vector`) of selected values from `choices`;
#' Type and size depends on variable type. Factors are coerced to character.
#' @param multiple (optional `logical(1)`) flag specifying whether more than one value can be selected;
#' only applicable to `ChoicesFilterState` and `LogicalFilterState`
#' @param keep_na (optional `logical(1)`) flag specifying whether to keep missing values
#' @param keep_inf (optional `logical(1)`) 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 (optional `character(1)`) title of the filter. Ignored when `varname` is set.
#' @param ... in `teal_slice` method these are additional arguments which can be handled by extensions
#'  of `teal.slice` classes. In other methods these are further arguments passed to or from other methods.
#' @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.
#'
#' @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`]
#'
#' @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
}

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

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

#' @rdname teal_slice
#' @export
#' @keywords internal
#'
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
#' @export
#' @keywords internal
#'
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
#' @export
#' @keywords internal
#'
print.teal_slice <- function(x, ...) {
  cat(format(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 = " "
      )
    }
  })
}

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

#' Complete filter specification
#'
#' Create `teal_slices` object to package multiple filters and additional settings.
#'
#' `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. For `print` and `format`,
#'  additional arguments passed to other functions.
#' @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
#' @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`
#'
#' @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
#'
#' @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))
  )
}


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


#' @rdname teal_slices
#' @export
#' @keywords internal
#'
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
#' @export
#' @keywords internal
#'
as.list.teal_slices <- function(x, recursive = FALSE, ...) { # nolint
  ans <- unclass(x)
  if (recursive) ans[] <- lapply(ans, as.list)
  ans
}


#' @rdname teal_slices
#' @export
#' @keywords internal
#'
`[.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
#' @export
#' @keywords internal
#'
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
#' @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
#' @keywords internal
#'
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
#' @export
#' @keywords internal
#'
print.teal_slices <- function(x, ...) {
  cat(format(x, ...), "\n")
}


#' `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)
}

# 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.
    #' @return An empty `div`.
    ui_active = function(id) {
      ns <- NS(id)
      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)
      div()
    }
  ),
  private = list(
    # private methods ----
    # private fields ----
  )
)

# 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({
        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")
    }
  )
)

#' Initialize `FilteredData`
#'
#' Function creates a `FilteredData` object.
#'
#' @param x (`named list`) of datasets.
#' @param join_keys (`join_keys`) see [`teal.data::join_keys()`].
#' @param code `r lifecycle::badge("deprecated")`
#' @param check `r lifecycle::badge("deprecated")`
#'
#' @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(), code, check) { # nolint
  checkmate::assert_list(x, any.missing = FALSE, names = "unique")
  checkmate::assert_class(join_keys, "join_keys")
  if (!missing(code)) {
    lifecycle::deprecate_stop(
      "0.5.0",
      "init_filtered_data(code = 'No longer supported')"
    )
  }
  if (!missing(check)) {
    lifecycle::deprecate_stop(
      "0.5.0",
      "init_filtered_data(check = 'No longer supported')"
    )
  }
  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(
              "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")),
#'   br(),
#'   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", 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)
  }
}

# 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, div(
#'     h4("ChoicesFilterState"),
#'     filter_state$ui("fs")
#'   )),
#'   column(8, div(
#'     h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_choices"), br(),
#'     h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_choices"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_choices"), 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 observers stored in `private$observers`.
    #'
    #' @return `NULL`, invisibly.
    #'
    destroy_observers = function() {
      lapply(private$observers, function(x) x$destroy())

      if (!is.null(private$destroy_shiny)) {
        private$destroy_shiny()
      }
      invisible(NULL)
    },

    # public shiny modules ----

    #' @description
    #' `shiny` module server.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return Reactive expression signaling that the remove button has been clicked.
    #'
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          private$server_summary("summary")

          private$destroy_shiny <- function() {
            logger::log_trace("Destroying FilterStateExpr inputs; id: { private$get_id() }")
            # remove values from the input list
            lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
          }

          reactive(input$remove) # back to parent to remove self
        }
      )
    },

    #' @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")
              },
              div(class = "filter-card-varname", tags$strong(private$teal_slice$id)),
              div(class = "filter-card-varlabel", private$teal_slice$title),
              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(
    observers = NULL, # stores observers
    teal_slice = NULL, # stores reactiveValues
    destroy_shiny = NULL, # function is set in server

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

.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")

  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_trace
  plotly::plot_ly
  shinycssloaders::withSpinner
  shinyWidgets::pickerOptions
  teal.data::datanames
  teal.widgets::optionalSelectInput
}


### END ENSURE CHECK PASSES

# 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, div(
#'     h4("Active filters"),
#'     filter_states_df$ui_active("fsdf")
#'   )),
#'   column(4, div(
#'     h4("Manual filter control"),
#'     filter_states_df$ui_add("add_filters"), br(),
#'     h4("Condition (i.e. call)"), # display the subset expression generated by this FilterStates
#'     textOutput("call_df"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_df"), br()
#'   )),
#'   column(4, div(
#'     h4("Programmatic filter control"),
#'     actionButton("button1_df", "set NUM1 < 30", width = "100%"), br(),
#'     actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), br(),
#'     actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"), br(),
#'     actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), br(),
#'     actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), br(),
#'     actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), br(),
#'     hr(),
#'     actionButton("button7_df", "remove NUM1", width = "100%"), br(),
#'     actionButton("button8_df", "remove NUM2", width = "100%"), br(),
#'     actionButton("button9_df", "remove CHAR1", width = "100%"), br(),
#'     actionButton("button10_df", "remove CHAR2", width = "100%"), br(),
#'     actionButton("button11_df", "remove DATE", width = "100%"), br(),
#'     actionButton("button12_df", "remove DATETIME", width = "100%"), br(),
#'     hr(),
#'     actionButton("button0_df", "clear all filters", width = "100%"), 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)
  )
)

#' 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
}

#' 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)
#' }
#'
#' @examplesIf requireNamespace("MultiAssayExperiment")
#' # 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, # nolint
                                  dataname,
                                  keys = character(0),
                                  parent_name = character(0),
                                  parent = reactive(dataset),
                                  join_keys = character(0),
                                  label = attr(dataset, "label")) {
  UseMethod("init_filtered_dataset")
}

#' @keywords internal
#' @export
init_filtered_dataset.data.frame <- function(dataset, # nolint
                                             dataname,
                                             keys = character(0),
                                             parent_name = character(0),
                                             parent = NULL,
                                             join_keys = character(0),
                                             label = attr(dataset, "label")) {
  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, # nolint
                                                       dataname,
                                                       keys = character(0),
                                                       parent_name, # ignored
                                                       parent, # ignored
                                                       join_keys, # ignored
                                                       label = attr(dataset, "label")) {
  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, # nolint
                                          dataname,
                                          keys, # ignored
                                          parent_name, # ignored
                                          parent, # ignored
                                          join_keys, # ignored
                                          label = attr(dataset, "label")) {
  DefaultFilteredDataset$new(
    dataset = dataset,
    dataname = dataname,
    label = label
  )
}

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

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

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`)
48		#' optional 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	23x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
56	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
57		}
58	23x	checkmate::assert_class(dataset, "MultiAssayExperiment")
59	21x	super$initialize(dataset, dataname, keys, label)
60	21x	experiment_names <- names(dataset)
61
62		# subsetting by subjects means subsetting by colData(MAE)
63	21x	private$add_filter_states(
64	21x	filter_states = init_filter_states(
65	21x	data = dataset,
66	21x	data_reactive = private$data_filtered_fun,
67	21x	dataname = dataname,
68	21x	datalabel = "subjects",
69	21x	keys = self$get_keys()
70		),
71	21x	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	21x	lapply(
77	21x	experiment_names,
78	21x	function(experiment_name) {
79	105x	data_reactive <- function(sid = "") private$data_filtered_fun(sid)[[experiment_name]]
80	105x	private$add_filter_states(
81	105x	filter_states = init_filter_states(
82	105x	data = dataset[[experiment_name]],
83	105x	data_reactive = data_reactive,
84	105x	dataname = dataname,
85	105x	datalabel = experiment_name
86		),
87	105x	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	15x	isolate({
101	15x	logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
102	15x	checkmate::assert_class(state, "teal_slices")
103	14x	lapply(state, function(x) {
104	52x	checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname")
105		})
106
107		# set state on subjects
108	14x	subject_state <- Filter(function(x) is.null(x$experiment), state)
109	14x	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	14x	experiments <- unique(unlist(lapply(state, "[[", "experiment")))
114	14x	available_experiments <- setdiff(names(private$get_filter_states()), "subjects")
115	14x	excluded_filters <- setdiff(experiments, available_experiments)
116	14x	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	14x	lapply(available_experiments, function(experiment) {
127	70x	slices <- Filter(function(x) identical(x$experiment, experiment), state)
128	70x	private$get_filter_states()[[experiment]]$set_filter_state(slices)
129		})
130
131	14x	logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
132
133	14x	invisible(NULL)
134		})
135		},
136
137		#' @description
138		#' Remove one or more `FilterState` of a `MAEFilteredDataset`.
139		#'
140		#' @param state (`teal_slices`)
141		#' specifying `FilterState` objects to remove;
142		#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored.
143		#'
144		#' @return `NULL`, invisibly.
145		#'
146		remove_filter_state = function(state) {
147	1x	checkmate::assert_class(state, "teal_slices")
148
149	1x	isolate({
150	1x	logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")
151		# remove state on subjects
152	1x	subject_state <- Filter(function(x) is.null(x$experiment), state)
153	1x	private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state)
154
155		# remove state on experiments
156		# determine target experiments (defined in teal_slices)
157	1x	experiments <- unique(unlist(lapply(state, "[[", "experiment")))
158	1x	available_experiments <- setdiff(names(private$get_filter_states()), "subjects")
159	1x	excluded_filters <- setdiff(experiments, available_experiments)
160	1x	if (length(excluded_filters)) {
161	!	stop(sprintf(
162	!	"%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",
163	!	private$dataname,
164	!	toString(excluded_filters),
165	!	toString(available_experiments)
166		))
167		}
168		# remove states on state_lists with corresponding experiments
169	1x	lapply(experiments, function(experiment) {
170	!	slices <- Filter(function(x) identical(x$experiment, experiment), state)
171	!	private$get_filter_states()[[experiment]]$remove_filter_state(slices)
172		})
173
174
175	1x	logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
176		})
177
178	1x	invisible(NULL)
179		},
180
181		#' @description
182		#' UI module to add filter variable for this dataset.
183		#' @param id (`character(1)`)
184		#' `shiny` module instance id.
185		#'
186		#' @return `shiny.tag`
187		#'
188		ui_add = function(id) {
189	!	ns <- NS(id)
190	!	data <- self$get_dataset()
191	!	experiment_names <- names(data)
192
193	!	div(
194	!	tags$label("Add", tags$code(self$get_dataname()), "filter"),
195	!	br(),
196	!	HTML("►"),
197	!	tags$label("Add subjects filter"),
198	!	private$get_filter_states()[["subjects"]]$ui_add(id = ns("subjects")),
199	!	tagList(
200	!	lapply(
201	!	experiment_names,
202	!	function(experiment_name) {
203	!	tagList(
204	!	HTML("►"),
205	!	tags$label("Add", tags$code(experiment_name), "filter"),
206	!	private$get_filter_states()[[experiment_name]]$ui_add(id = ns(experiment_name))
207		)
208		}
209		)
210		)
211		)
212		},
213
214		#' @description
215		#' Creates row for filter overview in the form of \cr
216		#' `dataname -- observations (remaining/total) -- subjects (remaining/total)` - MAE
217		#' @return A `data.frame`.
218		get_filter_overview = function() {
219	2x	data <- self$get_dataset()
220	2x	data_filtered <- self$get_dataset(TRUE)
221	2x	experiment_names <- names(data)
222
223	2x	mae_info <- data.frame(
224	2x	dataname = private$dataname,
225	2x	subjects = nrow(SummarizedExperiment::colData(data)),
226	2x	subjects_filtered = nrow(SummarizedExperiment::colData(data_filtered()))
227		)
228
229	2x	experiment_obs_info <- do.call("rbind", lapply(
230	2x	experiment_names,
231	2x	function(experiment_name) {
232	10x	data.frame(
233	10x	dataname = sprintf("- %s", experiment_name),
234	10x	obs = nrow(data[[experiment_name]]),
235	10x	obs_filtered = nrow(data_filtered()[[experiment_name]])
236		)
237		}
238		))
239
240	2x	get_experiment_keys <- function(mae, experiment) {
241	20x	sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment))
242	20x	length(unique(sample_subset$primary))
243		}
244
245	2x	experiment_subjects_info <- do.call("rbind", lapply(
246	2x	experiment_names,
247	2x	function(experiment_name) {
248	10x	data.frame(
249	10x	subjects = get_experiment_keys(data, data[[experiment_name]]),
250	10x	subjects_filtered = get_experiment_keys(data_filtered(), data_filtered()[[experiment_name]])
251		)
252		}
253		))
254
255	2x	experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)
256	2x	dplyr::bind_rows(mae_info, experiment_info)
257		}
258		)
259		)

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)`)
29		#' optional 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	92x	if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
36	!	stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
37		}
38	92x	checkmate::assert_function(data_reactive, args = "sid")
39	92x	checkmate::assert_class(data, "SummarizedExperiment")
40	91x	super$initialize(data, data_reactive, dataname, datalabel)
41	91x	if (!is.null(datalabel)) {
42	84x	private$dataname_prefixed <- sprintf("%s[['%s']]", dataname, datalabel)
43		}
44		},
45
46		#' @description
47		#' Set filter state.
48		#'
49		#' @param state (`teal_slices`)
50		#' `teal_slice` objects should contain the field `arg %in% c("subset", "select")`
51		#'
52		#' @return `NULL`, invisibly.
53		#'
54		set_filter_state = function(state) {
55	61x	isolate({
56	61x	logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
57	61x	checkmate::assert_class(state, "teal_slices")
58	59x	lapply(state, function(x) {
59	17x	checkmate::assert_choice(x$arg, choices = c("subset", "select"), null.ok = TRUE, .var.name = "teal_slice$arg")
60		})
61	59x	count_type <- attr(state, "count_type")
62	59x	if (length(count_type)) {
63	8x	private$count_type <- count_type
64		}
65
66	59x	subset_states <- Filter(function(x) x$arg == "subset", state)
67	59x	private$set_filter_state_impl(
68	59x	state = subset_states,
69	59x	data = SummarizedExperiment::rowData(private$data),
70	59x	data_reactive = function(sid = "") {
71	!	data <- private$data_reactive()
72	!	if (!is.null(data)) {
73	!	SummarizedExperiment::rowData(data)
74		}
75		}
76		)
77
78	59x	select_states <- Filter(function(x) x$arg == "select", state)
79	59x	private$set_filter_state_impl(
80	59x	state = select_states,
81	59x	data = SummarizedExperiment::colData(private$data),
82	59x	data_reactive = function(sid = "") {
83	!	data <- private$data_reactive()
84	!	if (!is.null(data)) {
85	!	SummarizedExperiment::colData(data)
86		}
87		}
88		)
89
90	59x	logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
91	59x	invisible(NULL)
92		})
93		},
94
95		#' @description
96		#' `shiny` UI module to add filter variable.
97		#' @param id (`character(1)`)
98		#' `shiny` module instance id.
99		#' @return `shiny.tag`
100		ui_add = function(id) {
101	2x	data <- private$data
102	2x	checkmate::assert_string(id)
103	2x	ns <- NS(id)
104	2x	row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
105	1x	div("no sample variables available")
106	2x	} else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
107	1x	div("no samples available")
108		} else {
109	!	teal.widgets::optionalSelectInput(
110	!	ns("row_to_add"),
111	!	choices = NULL,
112	!	options = shinyWidgets::pickerOptions(
113	!	liveSearch = TRUE,
114	!	noneSelectedText = "Select gene variable"
115		)
116		)
117		}
118
119	2x	col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
120	1x	div("no sample variables available")
121	2x	} else if (nrow(SummarizedExperiment::colData(data)) == 0) {
122	1x	div("no samples available")
123		} else {
124	!	teal.widgets::optionalSelectInput(
125	!	ns("col_to_add"),
126	!	choices = NULL,
127	!	options = shinyWidgets::pickerOptions(
128	!	liveSearch = TRUE,
129	!	noneSelectedText = "Select sample variable"
130		)
131		)
132		}
133
134	2x	div(
135	2x	row_input,
136	2x	col_input
137		)
138		},
139
140		#' @description
141		#' `shiny` server module to add filter variable.
142		#'
143		#' Module controls available choices to select as a filter variable.
144		#' Selected filter variable is being removed from available choices.
145		#' Removed filter variable gets back to available choices.
146		#' This module unlike other `FilterStates` classes manages two
147		#' sets of filter variables - one for `colData` and another for
148		#' `rowData`.
149		#'
150		#' @param id (`character(1)`)
151		#' `shiny` module instance id.
152		#' @return `NULL`
153		srv_add = function(id) {
154	!	data <- private$data
155	!	data_reactive <- private$data_reactive
156	!	moduleServer(
157	!	id = id,
158	!	function(input, output, session) {
159	!	logger::log_trace("SEFilterState$srv_add initializing, dataname: { private$dataname }")
160
161	!	row_data <- SummarizedExperiment::rowData(data)
162	!	col_data <- SummarizedExperiment::colData(data)
163
164	!	avail_row_data_choices <- reactive({
165	!	slices_for_subset <- Filter(function(x) x$arg == "subset", self$get_filter_state())
166	!	active_filter_row_vars <- unique(unlist(lapply(slices_for_subset, "[[", "varname")))
167
168	!	choices <- setdiff(
169	!	get_supported_filter_varnames(data = row_data),
170	!	active_filter_row_vars
171		)
172
173	!	data_choices_labeled(
174	!	data = row_data,
175	!	choices = choices,
176	!	varlabels = character(0),
177	!	keys = NULL
178		)
179		})
180
181	!	avail_col_data_choices <- reactive({
182	!	slices_for_select <- Filter(function(x) x$arg == "select", self$get_filter_state())
183	!	active_filter_col_vars <- unique(unlist(lapply(slices_for_select, "[[", "varname")))
184
185	!	choices <- setdiff(
186	!	get_supported_filter_varnames(data = col_data),
187	!	active_filter_col_vars
188		)
189
190	!	data_choices_labeled(
191	!	data = col_data,
192	!	choices = choices,
193	!	varlabels = character(0),
194	!	keys = NULL
195		)
196		})
197
198	!	observeEvent(
199	!	avail_row_data_choices(),
200	!	ignoreNULL = TRUE,
201	!	handlerExpr = {
202	!	logger::log_trace(paste(
203	!	"SEFilterStates$srv_add@1 updating available row data choices,",
204	!	"dataname: { private$dataname }"
205		))
206	!	if (is.null(avail_row_data_choices())) {
207	!	shinyjs::hide("row_to_add")
208		} else {
209	!	shinyjs::show("row_to_add")
210		}
211	!	teal.widgets::updateOptionalSelectInput(
212	!	session,
213	!	"row_to_add",
214	!	choices = avail_row_data_choices()
215		)
216	!	logger::log_trace(paste(
217	!	"SEFilterStates$srv_add@1 updated available row data choices,",
218	!	"dataname: { private$dataname }"
219		))
220		}
221		)
222
223	!	observeEvent(
224	!	avail_col_data_choices(),
225	!	ignoreNULL = TRUE,
226	!	handlerExpr = {
227	!	logger::log_trace(paste(
228	!	"SEFilterStates$srv_add@2 updating available col data choices,",
229	!	"dataname: { private$dataname }"
230		))
231	!	if (is.null(avail_col_data_choices())) {
232	!	shinyjs::hide("col_to_add")
233		} else {
234	!	shinyjs::show("col_to_add")
235		}
236	!	teal.widgets::updateOptionalSelectInput(
237	!	session,
238	!	"col_to_add",
239	!	choices = avail_col_data_choices()
240		)
241	!	logger::log_trace(paste(
242	!	"SEFilterStates$srv_add@2 updated available col data choices,",
243	!	"dataname: { private$dataname }"
244		))
245		}
246		)
247
248	!	observeEvent(
249	!	eventExpr = input$col_to_add,
250	!	handlerExpr = {
251	!	logger::log_trace(
252	!	sprintf(
253	!	"SEFilterStates$srv_add@3 adding FilterState of column %s to col data, dataname: %s",
254	!	deparse1(input$col_to_add),
255	!	private$dataname
256		)
257		)
258	!	varname <- input$col_to_add
259	!	self$set_filter_state(teal_slices(
260	!	teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select")
261		))
262
263	!	logger::log_trace(
264	!	sprintf(
265	!	"SEFilterStates$srv_add@3 added FilterState of column %s to col data, dataname: %s",
266	!	deparse1(varname),
267	!	private$dataname
268		)
269		)
270		}
271		)
272
273
274	!	observeEvent(
275	!	eventExpr = input$row_to_add,
276	!	handlerExpr = {
277	!	logger::log_trace(
278	!	sprintf(
279	!	"SEFilterStates$srv_add@4 adding FilterState of variable %s to row data, dataname: %s",
280	!	deparse1(input$row_to_add),
281	!	private$dataname
282		)
283		)
284	!	varname <- input$row_to_add
285	!	self$set_filter_state(teal_slices(
286	!	teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset")
287		))
288
289	!	logger::log_trace(
290	!	sprintf(
291	!	"SEFilterStates$srv_add@4 added FilterState of variable %s to row data, dataname: %s",
292	!	deparse1(varname),
293	!	private$dataname
294		)
295		)
296		}
297		)
298
299	!	logger::log_trace("SEFilterState$srv_add initialized, dataname: { private$dataname }")
300	!	NULL
301		}
302		)
303		}
304		)
305		)

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	195x	checkmate::assert_class(x_reactive, "reactive")
67	194x	checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)
68	194x	checkmate::assert_class(slice, "teal_slice")
69	193x	if (length(extract_type) == 1) {
70	43x	checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
71		}
72
73	192x	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	191x	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	120x	args <- list(
122	120x	x = x,
123	120x	x_reactive = x_reactive,
124	120x	slice = slice,
125	120x	extract_type = extract_type
126		)
127
128	120x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
129	28x	do.call(ChoicesFilterState$new, args)
130		} else {
131	92x	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	31x	ChoicesFilterState$new(
142	31x	x = x,
143	31x	x_reactive = x_reactive,
144	31x	slice = slice,
145	31x	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	32x	ChoicesFilterState$new(
156	32x	x = x,
157	32x	x_reactive = x_reactive,
158	32x	slice = slice,
159	32x	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	119x	checkmate::assert_string(color)
257	119x	checkmate::assert(
258	119x	checkmate::check_number(alpha, lower = 0, upper = 1, null.ok = TRUE),
259	119x	checkmate::check_string(alpha, pattern = "[0-9a-f]{2}", null.ok = TRUE)
260		)
261
262		# locate file that describes the current theme
263	119x	sass_file <- if (utils::packageVersion("bslib") < as.package_version("0.5.1.9000")) {
264	!	bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]]
265		} else {
266	119x	bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]][[1]]
267		}
268	119x	sass_file <- attr(sass_file, "sass_file_path")
269
270		# load scss file that encodes variables
271	119x	variables_file <- readLines(sass_file)
272		# locate theme color variables
273	119x	ind <- grep("// scss-docs-(start\|end) theme-color-variables", variables_file)
274	119x	color_definitions <- variables_file[(ind[1] + 1L):(ind[2] - 1L)]
275
276		# extract colors names
277	119x	color_names <- sub("(\\$)(\\w.+)(:.+)", "\\2", color_definitions)
278
279		# verify that an available color was requested
280	119x	checkmate::assert_choice(color, color_names)
281
282		# extract color references
283	119x	color_references <- sub("(\\$)(\\w.+)(:\\s.+\\$)(\\w.+)(\\s.+)", "\\4", color_definitions)
284
285		# translate references to color codes
286	119x	color_specification <- structure(color_references, names = color_names)
287	119x	color_specification <- vapply(color_specification, function(x) {
288	952x	line <- grep(sprintf("^\\$%s:\\s+#\\w{6}\\s+!default", x), variables_file, value = TRUE)
289	952x	code <- sub("(.+)(#\\w{6})(\\s+.+)", "\\2", line)
290	952x	code
291	119x	}, character(1L))
292
293	119x	if (!is.null(alpha)) {
294	!	if (is.numeric(alpha)) alpha <- as.hexmode(ceiling(255 * alpha))
295		}
296
297	119x	paste0(color_specification[color], alpha)
298		}

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, div(
42		#' h4("LogicalFilterState"),
43		#' fs$ui("fs")
44		#' )),
45		#' column(4, div(
46		#' id = "outputs", # div id is needed for toggling the element
47		#' h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
48		#' textOutput("condition_logical"), br(),
49		#' h4("Unformatted state"), # display raw filter state
50		#' textOutput("unformatted_logical"), br(),
51		#' h4("Formatted state"), # display human readable filter state
52		#' textOutput("formatted_logical"), br()
53		#' )),
54		#' column(4, div(
55		#' h4("Programmatic filter control"),
56		#' actionButton("button1_logical", "set drop NA", width = "100%"), br(),
57		#' actionButton("button2_logical", "set keep NA", width = "100%"), br(),
58		#' actionButton("button3_logical", "set a selection", width = "100%"), br(),
59		#' actionButton("button0_logical", "set initial state", width = "100%"), 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	!	div(
276	!	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_trace("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$observers$seleted_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_trace("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$observers$selection <- observeEvent(
339	!	ignoreNULL = FALSE,
340	!	ignoreInit = TRUE,
341	!	eventExpr = input$selection,
342	!	handlerExpr = {
343	!	logger::log_trace("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	!	logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
361	!	NULL
362		}
363		)
364		},
365		server_inputs_fixed = function(id) {
366	!	moduleServer(
367	!	id = id,
368	!	function(input, output, session) {
369	!	logger::log_trace("LogicalFilterState$server initializing, id: { private$get_id() }")
370
371	!	output$selection <- renderUI({
372	!	countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices())))
373	!	countsmax <- private$choices_counts
374
375	!	ind <- private$get_choices() %in% private$get_selected()
376	!	countBars(
377	!	inputId = session$ns("labels"),
378	!	choices = private$get_selected(),
379	!	countsnow = countsnow[ind],
380	!	countsmax = countsmax[ind]
381		)
382		})
383
384	!	logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
385	!	NULL
386		}
387		)
388		},
389
390		# @description
391		# Server module to display filter summary
392		# renders text describing whether TRUE or FALSE is selected
393		# and if NA are included also
394		content_summary = function(id) {
395	!	tagList(
396	!	tags$span(
397	!	class = "filter-card-summary-value",
398	!	toString(private$get_selected())
399		),
400	!	tags$span(
401	!	class = "filter-card-summary-controls",
402	!	if (private$na_count > 0) {
403	!	tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
404		}
405		)
406		)
407		}
408		)
409		)

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`)
49		#' optional 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	103x	checkmate::assert_data_frame(dataset)
72	101x	super$initialize(dataset, dataname, keys, label)
73
74		# overwrite filtered_data if there is relationship with parent dataset
75	99x	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_trace("filtering data dataname: { dataname }, sid: { sid }")
86		} else {
87	!	logger::log_trace("filtering data dataname: { private$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	99x	private$add_filter_states(
99	99x	filter_states = init_filter_states(
100	99x	data = dataset,
101	99x	data_reactive = private$data_filtered_fun,
102	99x	dataname = dataname,
103	99x	keys = self$get_keys()
104		),
105	99x	id = "filter"
106		)
107
108		# todo: Should we make these defaults? It could be handled by the app developer
109	99x	if (!is.null(parent)) {
110	10x	fs <- teal_slices(
111	10x	exclude_varnames = structure(
112	10x	list(intersect(colnames(dataset), colnames(isolate(parent())))),
113	10x	names = private$dataname
114		)
115		)
116	10x	self$set_filter_state(fs)
117		}
118
119	99x	invisible(self)
120		},
121
122		#' @description
123		#' Gets the subset expression.
124		#'
125		#' This function returns subset expressions equivalent to selected items
126		#' within each of `filter_states`. Configuration of the expressions is constant and
127		#' depends on `filter_states` type and order which are set during initialization.
128		#' This class contains single `FilterStates` which contains single `state_list`
129		#' and all `FilterState` objects apply to one argument (`...`) in a `dplyr::filter` call.
130		#'
131		#' @param sid (`character`)
132		#' when specified, the method returns code containing conditions calls of
133		#' `FilterState` objects with `sid` different to that of this `sid` argument.
134		#'
135		#' @return Either a `list` of length 1 containing a filter `call`, or `NULL`.
136		get_call = function(sid = "") {
137	42x	logger::log_trace("DataframeFilteredDataset$get_call initializing for dataname: { private$dataname }")
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	logger::log_trace("DataframeFilteredDataset$get_call initializing for dataname: { private$dataname }")
181	42x	filter_call
182		},
183
184		#' @description
185		#' Set filter state.
186		#'
187		#' @param state (`teal_slices`)
188		#' @return `NULL`, invisibly.
189		#'
190		set_filter_state = function(state) {
191	81x	isolate({
192	81x	logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
193	81x	checkmate::assert_class(state, "teal_slices")
194	80x	lapply(state, function(slice) {
195	97x	checkmate::assert_true(slice$dataname == private$dataname)
196		})
197	80x	private$get_filter_states()[[1L]]$set_filter_state(state = state)
198	80x	invisible(NULL)
199		})
200		},
201
202		#' @description
203		#' Remove one or more `FilterState` form a `FilteredDataset`.
204		#'
205		#' @param state (`teal_slices`)
206		#' specifying `FilterState` objects to remove;
207		#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored
208		#'
209		#' @return `NULL`, invisibly.
210		#'
211		remove_filter_state = function(state) {
212	11x	checkmate::assert_class(state, "teal_slices")
213
214	11x	isolate({
215	11x	logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")
216
217	11x	varnames <- unique(unlist(lapply(state, "[[", "varname")))
218	11x	private$get_filter_states()[[1]]$remove_filter_state(state)
219
220	11x	logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
221		})
222
223	11x	invisible(NULL)
224		},
225
226		#' @description
227		#' UI module to add filter variable for this dataset.
228		#'
229		#' @param id (`character(1)`)
230		#' `shiny` module instance id.
231		#'
232		#' @return `shiny.tag`
233		ui_add = function(id) {
234	!	ns <- NS(id)
235	!	tagList(
236	!	tags$label("Add", tags$code(self$get_dataname()), "filter"),
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_trace("FilteredDataset$srv_filter_overview initialized")
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		#' 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		#' @examplesIf requireNamespace("MultiAssayExperiment")
64		#'
65		#' # Requires MultiAssayExperiment from Bioconductor
66		#' data(miniACC, package = "MultiAssayExperiment")
67		#'
68		#' datasets <- init_filtered_data(list(mae = miniACC))
69		#' fs <- teal_slices(
70		#' teal_slice(
71		#' dataname = "mae", varname = "years_to_birth", selected = c(30, 50),
72		#' keep_na = TRUE, keep_inf = FALSE
73		#' ),
74		#' teal_slice(
75		#' dataname = "mae", varname = "vital_status", selected = "1",
76		#' keep_na = FALSE
77		#' ),
78		#' teal_slice(
79		#' dataname = "mae", varname = "gender", selected = "female",
80		#' keep_na = TRUE
81		#' ),
82		#' teal_slice(
83		#' dataname = "mae", varname = "ARRAY_TYPE", selected = "",
84		#' keep_na = TRUE, experiment = "RPPAArray", arg = "subset"
85		#' )
86		#' )
87		#'
88		#' # set initial filter state
89		#' set_filter_state(datasets, filter = fs)
90		#'
91		#' # get filter state
92		#' get_filter_state(datasets)
93		#'
94		#' # modify filter state
95		#' set_filter_state(
96		#' datasets,
97		#' teal_slices(
98		#' teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(40, 60))
99		#' )
100		#' )
101		#'
102		#' # remove specific filters
103		#' remove_filter_state(
104		#' datasets,
105		#' teal_slices(
106		#' teal_slice(dataname = "mae", varname = "years_to_birth"),
107		#' teal_slice(dataname = "mae", varname = "vital_status")
108		#' )
109		#' )
110		#'
111		#' # remove all states
112		#' clear_filter_states(datasets)
113		NULL
114
115		#' @rdname filter_state_api
116		#' @export
117		set_filter_state <- function(datasets, filter) {
118	3x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
119	3x	checkmate::assert_class(filter, "teal_slices")
120	3x	datasets$set_filter_state(filter)
121	3x	invisible(NULL)
122		}
123
124		#' @rdname filter_state_api
125		#' @export
126		get_filter_state <- function(datasets) {
127	4x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
128	4x	if (isRunning()) {
129	!	datasets$get_filter_state()
130		} else {
131	4x	isolate(datasets$get_filter_state())
132		}
133		}
134
135		#' @rdname filter_state_api
136		#' @export
137		remove_filter_state <- function(datasets, filter) {
138	1x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
139	1x	checkmate::assert_class(filter, "teal_slices")
140
141	1x	datasets$remove_filter_state(filter)
142	1x	invisible(NULL)
143		}
144
145		#' @rdname filter_state_api
146		#' @export
147		clear_filter_states <- function(datasets, force = FALSE) {
148	1x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
149	1x	datasets$clear_filter_states(force = force)
150	1x	invisible(NULL)
151		}
152
153		#' Gets filter expression for multiple `datanames` taking into account its order.
154		#'
155		#' @description `r lifecycle::badge("stable")`
156		#'
157		#' To be used in `Show R Code` button.
158		#'
159		#' @param datasets (`FilteredData`)
160		#' @param datanames (`character`) vector of dataset names
161		#'
162		#' @return A character string containing all subset expressions.
163		#'
164		#' @export
165		#'
166		get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
167	2x	checkmate::assert_character(datanames, min.len = 1, any.missing = FALSE)
168	2x	stopifnot(
169	2x	is(datasets, "FilteredData"),
170	2x	all(datanames %in% datasets$datanames())
171		)
172
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		#' 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	9x	if (is.factor(choices)) {
25	!	choices <- as.character(choices)
26		}
27
28	9x	stopifnot(
29	9x	is.character(choices) \|\|
30	9x	is.numeric(choices) \|\|
31	9x	is.logical(choices) \|\|
32	9x	(length(choices) == 1 && is.na(choices))
33		)
34
35	9x	if (is.factor(labels)) {
36	!	labels <- as.character(labels)
37		}
38
39	9x	checkmate::assert_character(labels[!is.na(labels)], any.missing = FALSE)
40	9x	if (length(choices) != length(labels)) {
41	!	stop("length of choices must be the same as labels")
42		}
43	9x	stopifnot(is.null(subset) \|\| is.vector(subset))
44	9x	stopifnot(is.null(types) \|\| is.vector(types))
45
46	9x	if (is.vector(types)) {
47	9x	stopifnot(length(choices) == length(types))
48		}
49
50	9x	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	9x	is_dupl <- duplicated(choices)
60	9x	choices <- choices[!is_dupl]
61	9x	labels <- labels[!is_dupl]
62	9x	types <- types[!is_dupl]
63	9x	labels[is.na(labels)] <- "Label Missing"
64	9x	raw_labels <- labels
65	9x	combined_labels <- if (length(choices) > 0) {
66	9x	paste0(choices, ": ", labels)
67		} else {
68	!	character(0)
69		}
70
71	9x	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	9x	choices <- structure(
79	9x	choices,
80	9x	names = combined_labels,
81	9x	raw_labels = raw_labels,
82	9x	combined_labels = combined_labels,
83	9x	class = c("choices_labeled", "character"),
84	9x	types = types
85		)
86
87	9x	choices
88		}

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, div(
51		#' h4("DateFilterState"),
52		#' fs$ui("fs")
53		#' )),
54		#' column(4, div(
55		#' id = "outputs", # div id is needed for toggling the element
56		#' h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
57		#' textOutput("condition_date"), br(),
58		#' h4("Unformatted state"), # display raw filter state
59		#' textOutput("unformatted_date"), br(),
60		#' h4("Formatted state"), # display human readable filter state
61		#' textOutput("formatted_date"), br()
62		#' )),
63		#' column(4, div(
64		#' h4("Programmatic filter control"),
65		#' actionButton("button1_date", "set drop NA", width = "100%"), br(),
66		#' actionButton("button2_date", "set keep NA", width = "100%"), br(),
67		#' actionButton("button3_date", "set a range", width = "100%"), br(),
68		#' actionButton("button4_date", "set full range", width = "100%"), br(),
69		#' actionButton("button0_date", "set initial state", width = "100%"), 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(max(choices[1L], min(private$x)), min(choices[2L], max(private$x)))
195	3x	if (any(choices != choices_adjusted)) {
196	1x	warning(sprintf(
197	1x	"Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",
198	1x	private$get_varname(), private$get_dataname()
199		))
200	1x	choices <- choices_adjusted
201		}
202	3x	if (choices[1L] >= choices[2L]) {
203	1x	warning(sprintf(
204	1x	"Invalid choices: lower is higher / equal to upper, or not in range of variable values.
205	1x	Setting defaults. Varname: %s, dataname: %s.",
206	1x	private$get_varname(), private$get_dataname()
207		))
208	1x	choices <- range(private$x, na.rm = TRUE)
209		}
210		}
211	22x	private$set_is_choice_limited(private$x, choices)
212	22x	private$x <- private$x[(private$x >= choices[1L] & private$x <= choices[2L]) \| is.na(private$x)]
213	22x	private$teal_slice$choices <- choices
214	22x	invisible(NULL)
215		},
216
217		# @description
218		# Check whether the initial choices filter out some values of x and set the flag in case.
219		set_is_choice_limited = function(xl, choices) {
220	22x	private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) \| any(xl > choices[2L], na.rm = TRUE))
221	22x	invisible(NULL)
222		},
223		cast_and_validate = function(values) {
224	33x	tryCatch(
225	33x	expr = {
226	33x	values <- as.Date(values, origin = "1970-01-01")
227	!	if (anyNA(values)) stop()
228	30x	values
229		},
230	33x	error = function(e) stop("Vector of set values must contain values coercible to Date.")
231		)
232		},
233		check_length = function(values) {
234	1x	if (length(values) != 2) stop("Vector of set values must have length two.")
235	29x	if (values[1] > values[2]) {
236	1x	warning(
237	1x	sprintf(
238	1x	"Start date %s is set after the end date %s, the values will be replaced with a default date range.",
239	1x	values[1], values[2]
240		)
241		)
242	1x	values <- isolate(private$get_choices())
243		}
244	29x	values
245		},
246		remove_out_of_bounds_values = function(values) {
247	29x	choices <- private$get_choices()
248	29x	if (values[1] < choices[1L] \| values[1] > choices[2L]) {
249	5x	warning(
250	5x	sprintf(
251	5x	"Value: %s is outside of the possible range for column %s of dataset %s, setting minimum possible value.",
252	5x	values[1], private$get_varname(), private$get_dataname()
253		)
254		)
255	5x	values[1] <- choices[1L]
256		}
257
258	29x	if (values[2] > choices[2L] \| values[2] < choices[1L]) {
259	5x	warning(
260	5x	sprintf(
261	5x	"Value: %s is outside of the possible range for column %s of dataset %s, setting maximum possible value.",
262	5x	values[2], private$get_varname(), private$get_dataname()
263		)
264		)
265	5x	values[2] <- choices[2L]
266		}
267
268	29x	values
269		},
270
271		# shiny modules ----
272
273		# @description
274		# UI Module for `DateFilterState`.
275		# This UI element contains two date selections for `min` and `max`
276		# of the range and a checkbox whether to keep the `NA` values.
277		# @param id (`character(1)`) `shiny` module instance id.
278		ui_inputs = function(id) {
279	!	ns <- NS(id)
280	!	isolate({
281	!	div(
282	!	div(
283	!	class = "flex",
284	!	actionButton(
285	!	class = "date_reset_button",
286	!	inputId = ns("start_date_reset"),
287	!	label = NULL,
288	!	icon = icon("fas fa-undo")
289		),
290	!	div(
291	!	class = "w-80 filter_datelike_input",
292	!	dateRangeInput(
293	!	inputId = ns("selection"),
294	!	label = NULL,
295	!	start = private$get_selected()[1],
296	!	end = private$get_selected()[2],
297	!	min = private$get_choices()[1L],
298	!	max = private$get_choices()[2L],
299	!	width = "100%"
300		)
301		),
302	!	actionButton(
303	!	class = "date_reset_button",
304	!	inputId = ns("end_date_reset"),
305	!	label = NULL,
306	!	icon = icon("fas fa-undo")
307		)
308		),
309	!	private$keep_na_ui(ns("keep_na"))
310		)
311		})
312		},
313
314		# @description
315		# Server module
316		# @param id (`character(1)`) `shiny` module instance id.
317		# @return `NULL`.
318		server_inputs = function(id) {
319	!	moduleServer(
320	!	id = id,
321	!	function(input, output, session) {
322	!	logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }")
323
324		# this observer is needed in the situation when teal_slice$selected has been
325		# changed directly by the api - then it's needed to rerender UI element
326		# to show relevant values
327	!	private$observers$seletion_api <- observeEvent(
328	!	ignoreNULL = TRUE, # dates needs to be selected
329	!	ignoreInit = TRUE,
330	!	eventExpr = private$get_selected(),
331	!	handlerExpr = {
332	!	if (!setequal(private$get_selected(), input$selection)) {
333	!	logger::log_trace("DateFilterState$server@1 state changed, id: { private$get_id() }")
334	!	updateDateRangeInput(
335	!	session = session,
336	!	inputId = "selection",
337	!	start = private$get_selected()[1],
338	!	end = private$get_selected()[2]
339		)
340		}
341		}
342		)
343
344	!	private$observers$selection <- observeEvent(
345	!	ignoreNULL = TRUE, # dates needs to be selected
346	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
347	!	eventExpr = input$selection,
348	!	handlerExpr = {
349	!	logger::log_trace("DateFilterState$server@2 selection changed, id: { private$get_id() }")
350	!	start_date <- input$selection[1]
351	!	end_date <- input$selection[2]
352
353	!	if (is.na(start_date) \|\| is.na(end_date) \|\| start_date > end_date) {
354	!	updateDateRangeInput(
355	!	session = session,
356	!	inputId = "selection",
357	!	start = private$get_selected()[1],
358	!	end = private$get_selected()[2]
359		)
360	!	showNotification(
361	!	"Start date must not be greater than the end date. Setting back to previous value.",
362	!	type = "warning"
363		)
364	!	return(NULL)
365		}
366
367	!	private$set_selected(c(start_date, end_date))
368		}
369		)
370
371
372	!	private$keep_na_srv("keep_na")
373
374	!	private$observers$reset1 <- observeEvent(input$start_date_reset, {
375	!	logger::log_trace("DateFilterState$server@3 reset start date, id: { private$get_id() }")
376	!	updateDateRangeInput(
377	!	session = session,
378	!	inputId = "selection",
379	!	start = private$get_choices()[1L]
380		)
381		})
382
383	!	private$observers$reset2 <- observeEvent(input$end_date_reset, {
384	!	logger::log_trace("DateFilterState$server@4 reset end date, id: { private$get_id() }")
385	!	updateDateRangeInput(
386	!	session = session,
387	!	inputId = "selection",
388	!	end = private$get_choices()[2L]
389		)
390		})
391
392	!	logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
393	!	NULL
394		}
395		)
396		},
397		server_inputs_fixed = function(id) {
398	!	moduleServer(
399	!	id = id,
400	!	function(input, output, session) {
401	!	logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }")
402
403	!	output$selection <- renderUI({
404	!	vals <- format(private$get_selected(), nsmall = 3)
405	!	div(
406	!	div(icon("calendar-days"), vals[1]),
407	!	div(span(" - "), icon("calendar-days"), vals[2])
408		)
409		})
410
411	!	logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
412	!	NULL
413		}
414		)
415		},
416
417		# @description
418		# Server module to display filter summary
419		# renders text describing selected date range and
420		# if NA are included also
421		content_summary = function(id) {
422	!	selected <- as.character(private$get_selected())
423	!	min <- selected[1]
424	!	max <- selected[2]
425	!	tagList(
426	!	tags$span(
427	!	class = "filter-card-summary-value",
428	!	HTML(min, "–", max)
429		),
430	!	tags$span(
431	!	class = "filter-card-summary-controls",
432	!	if (private$na_count > 0) {
433	!	tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
434		}
435		)
436		)
437		}
438		)
439		)

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, div(
51		#' h4("DatetimeFilterState"),
52		#' fs$ui("fs")
53		#' )),
54		#' column(4, div(
55		#' id = "outputs", # div id is needed for toggling the element
56		#' h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
57		#' textOutput("condition_datetime"), br(),
58		#' h4("Unformatted state"), # display raw filter state
59		#' textOutput("unformatted_datetime"), br(),
60		#' h4("Formatted state"), # display human readable filter state
61		#' textOutput("formatted_datetime"), br()
62		#' )),
63		#' column(4, div(
64		#' h4("Programmatic filter control"),
65		#' actionButton("button1_datetime", "set drop NA", width = "100%"), br(),
66		#' actionButton("button2_datetime", "set keep NA", width = "100%"), br(),
67		#' actionButton("button3_datetime", "set a range", width = "100%"), br(),
68		#' actionButton("button4_datetime", "set full range", width = "100%"), br(),
69		#' actionButton("button0_datetime", "set initial state", width = "100%"), 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	!	div(
359	!	div(
360	!	class = "flex",
361	!	ui_reset_1,
362	!	div(
363	!	class = "flex w-80 filter_datelike_input",
364	!	div(class = "w-45 text-center", ui_input_1),
365	!	span(
366	!	class = "input-group-addon w-10",
367	!	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	!	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_trace("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$observers$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_trace("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$observers$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_trace("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$observers$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_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
473		}
474		)
475
476	!	private$keep_na_srv("keep_na")
477
478	!	private$observers$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_trace("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
489		}
490		)
491	!	private$observers$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_trace("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
502		}
503		)
504
505	!	logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
506	!	NULL
507		}
508		)
509		},
510		server_inputs_fixed = function(id) {
511	!	moduleServer(
512	!	id = id,
513	!	function(input, output, session) {
514	!	logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
515
516	!	output$selection <- renderUI({
517	!	vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3)
518	!	div(
519	!	div(icon("clock"), vals[1]),
520	!	div(span(" - "), icon("clock"), vals[2])
521		)
522		})
523
524	!	logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
525	!	NULL
526		}
527		)
528		},
529
530		# @description
531		# UI module to display filter summary
532		# renders text describing selected date range and
533		# if NA are included also
534		content_summary = function(id) {
535	!	selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S")
536	!	min <- selected[1]
537	!	max <- selected[2]
538	!	tagList(
539	!	tags$span(
540	!	class = "filter-card-summary-value",
541	!	HTML(min, "–", max)
542		),
543	!	tags$span(
544	!	class = "filter-card-summary-controls",
545	!	if (private$na_count > 0) {
546	!	tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
547		}
548		)
549		)
550		}
551		)
552		)

1		#' Test whether variable name can be used within `Show R Code`
2		#'
3		#' Variable names containing spaces are problematic and must be wrapped in backticks.
4		#' Also, they should not start with a number as `R` may silently make it valid by changing it.
5		#' Therefore, we only allow alphanumeric characters with underscores.
6		#' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters.
7		#'
8		#' @md
9		#'
10		#' @param name (`character`) vector of names to check
11		#' @return Returns `NULL` or raises error.
12		#' @keywords internal
13		#'
14		check_simple_name <- function(name) {
15	273x	checkmate::assert_character(name, min.len = 1, any.missing = FALSE)
16	271x	if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
17	5x	stop(
18	5x	"name '",
19	5x	name,
20	5x	"' must only contain alphanumeric characters (with underscores)",
21	5x	" and the first character must be an alphabetic character"
22		)
23		}
24		}
25
26		#' Include `JS` files from `/inst/js/` package directory to application header
27		#'
28		#' `system.file` should not be used to access files in other packages, it does
29		#' not work with `devtools`. Therefore, we redefine this method in each package
30		#' as needed. Thus, we do not export this method.
31		#'
32		#' @param pattern (`character`) pattern of files to be included, passed to `system.file`
33		#' @param except (`character`) vector of basename filenames to be excluded
34		#'
35		#' @return HTML code that includes `JS` files
36		#' @keywords internal
37		include_js_files <- function(pattern) {
38	12x	checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE)
39	12x	js_files <- list.files(
40	12x	system.file("js", package = "teal.slice", mustWork = TRUE),
41	12x	pattern = pattern,
42	12x	full.names = TRUE
43		)
44	12x	return(singleton(lapply(js_files, includeScript)))
45		}
46
47		#' Build concatenating call
48		#'
49		#' This function takes a vector of values and returns a `c` call. If the vector
50		#' has only one element, the element is returned directly.
51		#'
52		#' @param choices A vector of values.
53		#'
54		#' @return A `c` call.
55		#'
56		#' @examples
57		#' # use non-exported function from teal.slice
58		#' make_c_call <- getFromNamespace("make_c_call", "teal.slice")
59		#' make_c_call(1:3)
60		#' make_c_call(1)
61		#'
62		#' @keywords internal
63		make_c_call <- function(choices) {
64	53x	if (length(choices) > 1) {
65	26x	do.call("call", append(list("c"), choices))
66		} else {
67	27x	choices
68		}
69		}

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)`)
29		#' Optional 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	26x	checkmate::assert_matrix(data)
36	25x	super$initialize(data, data_reactive, dataname, datalabel)
37	25x	private$set_filterable_varnames(include_varnames = colnames(private$data))
38		}
39		),
40		private = list(
41		extract_type = "matrix"
42		)
43		)

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

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`)
26		#' optional 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")) {
33	153x	logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
34
35		# dataset assertion in child classes
36	153x	check_simple_name(dataname)
37	151x	checkmate::assert_character(keys, any.missing = FALSE)
38	151x	checkmate::assert_character(label, null.ok = TRUE)
39
40	151x	logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
41	151x	private$dataset <- dataset
42	151x	private$dataname <- dataname
43	151x	private$keys <- keys
44	151x	private$label <- if (is.null(label)) character(0) else label
45
46		# function executing reactive call and returning data
47	151x	private$data_filtered_fun <- function(sid = "") {
48	24x	checkmate::assert_character(sid)
49	24x	if (length(sid)) {
50	24x	logger::log_trace("filtering data dataname: { dataname }, sid: { sid }")
51		} else {
52	!	logger::log_trace("filtering data dataname: { private$dataname }")
53		}
54	24x	env <- new.env(parent = parent.env(globalenv()))
55	24x	env[[dataname]] <- private$dataset
56	24x	filter_call <- self$get_call(sid)
57	24x	eval_expr_with_msg(filter_call, env)
58	24x	get(x = dataname, envir = env)
59		}
60
61	151x	private$data_filtered <- reactive(private$data_filtered_fun())
62	151x	logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
63	151x	invisible(self)
64		},
65
66		#' @description
67		#' Returns a formatted string representing this `FilteredDataset` object.
68		#'
69		#' @param show_all (`logical(1)`) passed to `format.teal_slice`.
70		#' @param trim_lines (`logical(1)`) passed to `format.teal_slice`.
71		#'
72		#' @return The formatted character string.
73		#'
74		format = function(show_all = FALSE, trim_lines = TRUE) {
75	24x	sprintf(
76	24x	"%s:\n%s",
77	24x	class(self)[1],
78	24x	format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)
79		)
80		},
81
82		#' @description
83		#' Prints this `FilteredDataset` object.
84		#'
85		#' @param ... additional arguments passed to `format`.
86		#'
87		print = function(...) {
88	10x	cat(isolate(self$format(...)), "\n")
89		},
90
91		#' @description
92		#' Removes all filter items applied to this dataset.
93		#'
94		#' @param force (`logical(1)`)
95		#' flag specifying whether to include anchored filter states.
96		#'
97		#' @return `NULL`.
98		clear_filter_states = function(force = FALSE) {
99	14x	logger::log_trace("Removing filters from FilteredDataset: { deparse1(self$get_dataname()) }")
100	14x	lapply(
101	14x	private$get_filter_states(),
102	14x	function(filter_states) filter_states$clear_filter_states(force)
103		)
104	14x	logger::log_trace("Removed filters from FilteredDataset: { deparse1(self$get_dataname()) }")
105	14x	NULL
106		},
107
108		# managing filter states -----
109
110		# getters ----
111		#' @description
112		#' Gets a filter expression.
113		#'
114		#' This function returns filter calls equivalent to selected items
115		#' within each of `filter_states`. Configuration of the calls is constant and
116		#' depends on `filter_states` type and order which are set during initialization.
117		#'
118		#' @param sid (`character`)
119		#' when specified, the method returns code containing conditions calls of
120		#' `FilterState` objects with `sid` different to this `sid` argument.
121		#'
122		#' @return Either a `list` of filter `call`s, or `NULL`.
123		get_call = function(sid = "") {
124	47x	filter_call <- Filter(
125	47x	f = Negate(is.null),
126	47x	x = lapply(private$get_filter_states(), function(x) x$get_call(sid))
127		)
128	47x	if (length(filter_call) == 0) {
129	29x	return(NULL)
130		}
131	18x	filter_call
132		},
133
134		#' @description
135		#' Gets states of all contained `FilterState` objects.
136		#'
137		#' @return A `teal_slices` object.
138		#'
139		get_filter_state = function() {
140	184x	states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state()))
141	184x	do.call(c, states)
142		},
143
144		#' @description
145		#' Set filter state.
146		#'
147		#' @param state (`teal_slices`)
148		#'
149		#' @return Virtual method, returns nothing and raises error.
150		#'
151		set_filter_state = function(state) {
152	!	stop("set_filter_state is an abstract class method.")
153		},
154
155		#' @description
156		#' Gets the number of `FilterState` objects in all `FilterStates` in this `FilteredDataset`.
157		#' @return `integer(1)`
158		get_filter_count = function() {
159	16x	length(self$get_filter_state())
160		},
161
162		#' @description
163		#' Gets the name of the dataset.
164		#'
165		#' @return A character string.
166		get_dataname = function() {
167	8x	private$dataname
168		},
169
170		#' @description
171		#' Gets the dataset object in this `FilteredDataset`.
172		#'
173		#' @param filtered (`logical(1)`)
174		#'
175		#' @return
176		#' The stored dataset. If `data.frame` or `MultiAssayExperiment`,
177		#' either raw or as a reactive with current filters applied (depending on `filtered`).
178		#'
179		get_dataset = function(filtered = FALSE) {
180	51x	if (filtered) {
181	33x	private$data_filtered
182		} else {
183	18x	private$dataset
184		}
185		},
186
187		#' @description
188		#' Get filter overview of a dataset.
189		#' @return Virtual method, returns nothing and raises an error.
190		get_filter_overview = function() {
191	!	stop("get_filter_overview is an abstract class method")
192		},
193
194		#' @description
195		#' Gets the key columns for this dataset.
196		#' @return Character vector of variable names
197		get_keys = function() {
198	133x	private$keys
199		},
200
201		#' @description
202		#' Gets the dataset label.
203		#' @return Character string.
204		get_dataset_label = function() {
205	2x	private$label
206		},
207
208		# modules ------
209		#' @description
210		#' `shiny` module containing active filters for a dataset, along with a title and a remove button.
211		#' @param id (`character(1)`)
212		#' `shiny` module instance id.
213		#'
214		#' @return `shiny.tag`
215		ui_active = function(id) {
216	!	dataname <- self$get_dataname()
217	!	checkmate::assert_string(dataname)
218
219	!	ns <- NS(id)
220	!	if_multiple_filter_states <- length(private$get_filter_states()) > 1
221	!	span(
222	!	id = id,
223	!	include_css_files("filter-panel"),
224	!	div(
225	!	id = ns("whole_ui"), # to hide it entirely
226	!	fluidRow(
227	!	column(
228	!	width = 8,
229	!	tags$span(dataname, class = "filter_panel_dataname")
230		),
231	!	column(
232	!	width = 4,
233	!	tagList(
234	!	actionLink(
235	!	ns("remove_filters"),
236	!	label = "",
237	!	icon = icon("circle-xmark", lib = "font-awesome"),
238	!	class = "remove pull-right"
239		),
240	!	actionLink(
241	!	ns("collapse"),
242	!	label = "",
243	!	icon = icon("angle-down", lib = "font-awesome"),
244	!	class = "remove pull-right"
245		)
246		)
247		)
248		),
249	!	shinyjs::hidden(
250	!	div(
251	!	id = ns("filter_count_ui"),
252	!	tagList(
253	!	textOutput(ns("filter_count")),
254	!	br()
255		)
256		)
257		),
258	!	div(
259		# id needed to insert and remove UI to filter single variable as needed
260		# it is currently also used by the above module to entirely hide this panel
261	!	id = ns("filters"),
262	!	class = "parent-hideable-list-group",
263	!	tagList(
264	!	lapply(
265	!	names(private$get_filter_states()),
266	!	function(x) {
267	!	tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x)))
268		}
269		)
270		)
271		)
272		)
273		)
274		},
275
276		#' @description
277		#' Server module for a dataset active filters.
278		#'
279		#' @param id (`character(1)`)
280		#' `shiny` module instance id.
281		#' @return `NULL`.
282		srv_active = function(id) {
283	7x	moduleServer(
284	7x	id = id,
285	7x	function(input, output, session) {
286	7x	dataname <- self$get_dataname()
287	7x	logger::log_trace("FilteredDataset$srv_active initializing, dataname: { dataname }")
288	7x	checkmate::assert_string(dataname)
289	7x	output$filter_count <- renderText(
290	7x	sprintf(
291	7x	"%d filter%s applied",
292	7x	self$get_filter_count(),
293	7x	if (self$get_filter_count() != 1) "s" else ""
294		)
295		)
296
297	7x	lapply(
298	7x	names(private$get_filter_states()),
299	7x	function(x) {
300	12x	private$get_filter_states()[[x]]$srv_active(id = x)
301		}
302		)
303
304	7x	observeEvent(self$get_filter_state(), {
305	8x	shinyjs::hide("filter_count_ui")
306	8x	shinyjs::show("filters")
307	8x	shinyjs::toggle("remove_filters", condition = length(self$get_filter_state()) != 0)
308	8x	shinyjs::toggle("collapse", condition = length(self$get_filter_state()) != 0)
309		})
310
311	7x	observeEvent(input$collapse, {
312	!	shinyjs::toggle("filter_count_ui")
313	!	shinyjs::toggle("filters")
314	!	toggle_icon(session$ns("collapse"), c("fa-angle-right", "fa-angle-down"))
315		})
316
317	7x	observeEvent(input$remove_filters, {
318	1x	logger::log_trace("FilteredDataset$srv_active@1 removing all non-anchored filters, dataname: { dataname }")
319	1x	self$clear_filter_states()
320	1x	logger::log_trace("FilteredDataset$srv_active@1 removed all non-anchored filters, dataname: { dataname }")
321		})
322
323	7x	logger::log_trace("FilteredDataset$initialized, dataname: { dataname }")
324
325	7x	NULL
326		}
327		)
328		},
329
330		#' @description
331		#' UI module to add filter variable for this dataset.
332		#'
333		#' @param id (`character(1)`)
334		#' `shiny` module instance id.
335		#'
336		#' @return Virtual method, returns nothing and raises error.
337		ui_add = function(id) {
338	1x	stop("Pure virtual method")
339		},
340
341		#' @description
342		#' Server module to add filter variable for this dataset.
343		#' For this class `srv_add` calls multiple modules
344		#' of the same name from `FilterStates` as `MAEFilteredDataset`
345		#' contains one `FilterStates` object for `colData` and one for each experiment.
346		#'
347		#' @param id (`character(1)`)
348		#' `shiny` module instance id.
349		#'
350		#' @return `NULL`.
351		srv_add = function(id) {
352	2x	moduleServer(
353	2x	id = id,
354	2x	function(input, output, session) {
355	2x	logger::log_trace("MAEFilteredDataset$srv_add initializing, dataname: { deparse1(self$get_dataname()) }")
356	2x	elems <- private$get_filter_states()
357	2x	elem_names <- names(private$get_filter_states())
358	2x	lapply(
359	2x	elem_names,
360	2x	function(elem_name) elems[[elem_name]]$srv_add(elem_name)
361		)
362	2x	logger::log_trace("MAEFilteredDataset$srv_add initialized, dataname: { deparse1(self$get_dataname()) }")
363	2x	NULL
364		}
365		)
366		}
367		),
368		# private fields ----
369		private = list(
370		dataset = NULL, # data.frame or MultiAssayExperiment
371		data_filtered = NULL,
372		data_filtered_fun = NULL, # function
373		filter_states = list(),
374		dataname = character(0),
375		keys = character(0),
376		label = character(0),
377
378		# Adds `FilterStates` to the `private$filter_states`.
379		# `FilterStates` is added once for each element of the dataset.
380		# @param filter_states (`FilterStates`)
381		# @param id (`character(1)`)
382		add_filter_states = function(filter_states, id) {
383	225x	checkmate::assert_class(filter_states, "FilterStates")
384	225x	checkmate::assert_string(id)
385	225x	x <- stats::setNames(list(filter_states), id)
386	225x	private$filter_states <- c(private$get_filter_states(), x)
387		},
388
389		# @description
390		# Gets `FilterStates` objects in this `FilteredDataset`.
391		# @return list of `FilterStates` objects.
392		get_filter_states = function() {
393	684x	private$filter_states
394		}
395		)
396		)

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		#' 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	25x	checkmate::assert_string(inputId)
76	21x	checkmate::assert_vector(choices)
77	20x	checkmate::assert_numeric(countsmax, len = length(choices))
78	17x	checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)
79	15x	if (!is.null(countsnow)) {
80	7x	checkmate::assert_true(all(countsnow <= countsmax))
81		}
82
83	14x	ns <- NS(inputId)
84
85	14x	mapply(
86	14x	countBar,
87	14x	inputId = ns(seq_along(choices)),
88	14x	label = as.character(choices),
89	14x	countmax = countsmax,
90	14x	countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
91	14x	MoreArgs = list(
92	14x	counttotal = sum(countsmax)
93		),
94	14x	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	62x	checkmate::assert_string(inputId)
120	58x	checkmate::assert_string(label)
121	55x	checkmate::assert_number(countmax)
122	53x	checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax)
123	51x	checkmate::assert_number(counttotal, lower = countmax)
124
125	49x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
126	49x	ns <- NS(inputId)
127	26x	if (is.null(countnow)) countnow <- 0
128	49x	tags$div(
129	49x	class = "progress state-count-container",
130		# * .9 to not exceed width of the parent html element
131	49x	tags$div(
132	49x	id = ns("count_bar_filtered"),
133	49x	class = "progress-bar state-count-bar-filtered",
134	49x	style = sprintf("width: %s%%", countnow / counttotal * 100),
135	49x	role = "progressbar",
136	49x	label
137		),
138	49x	tags$div(
139	49x	id = ns("count_bar_unfiltered"),
140	49x	class = "progress-bar state-count-bar-unfiltered",
141	49x	style = sprintf("width: %s%%", (countmax - countnow) / counttotal * 100),
142	49x	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	96x	checkmate::assert_string(label)
224	94x	checkmate::assert_number(countmax)
225	92x	checkmate::assert_number(countnow, null.ok = TRUE)
226	90x	sprintf(
227	90x	"%s (%s%s)",
228	90x	label,
229	90x	if (is.null(countnow)) "" else sprintf("%s/", countnow),
230	90x	countmax
231		)
232		}

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

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)`)
28		#' optional 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	26x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
40	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
41		}
42	26x	checkmate::assert_function(data_reactive, args = "sid")
43	26x	checkmate::assert_class(data, "MultiAssayExperiment")
44
45	25x	data <- SummarizedExperiment::colData(data)
46	25x	data_reactive <- function(sid = "") SummarizedExperiment::colData(data_reactive(sid = sid))
47	25x	super$initialize(data, data_reactive, dataname, datalabel)
48	25x	private$keys <- keys
49	25x	private$set_filterable_varnames(include_varnames = colnames(data))
50
51	25x	invisible(self)
52		}
53		),
54
55		# private fields ----
56
57		private = list(
58		extract_type = "list",
59		fun = quote(MultiAssayExperiment::subsetByColData)
60		)
61		)

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

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		#' @return An empty `div`.
102		ui_active = function(id) {
103	!	ns <- NS(id)
104	!	div()
105		},
106
107		#' @description
108		#' Overwrites parent method.
109		#' @details
110		#' Blank UI module that would list active filter states for this dataset.
111		#' @param id (`character(1)`)
112		#' `shiny` module instance id.
113		#' @return An empty `div`.
114		ui_add = function(id) {
115	!	ns <- NS(id)
116	!	div()
117		}
118		),
119		private = list(
120		# private methods ----
121		# private fields ----
122		)
123		)

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

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)`)
14		#' optional 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", 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	229x	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	100x	DFFilterStates$new(
76	100x	data = data,
77	100x	data_reactive = data_reactive,
78	100x	dataname = dataname,
79	100x	datalabel = datalabel,
80	100x	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	22x	MatrixFilterStates$new(
92	22x	data = data,
93	22x	data_reactive = data_reactive,
94	22x	dataname = dataname,
95	22x	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	22x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
108	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
109		}
110	22x	MAEFilterStates$new(
111	22x	data = data,
112	22x	data_reactive = data_reactive,
113	22x	dataname = dataname,
114	22x	datalabel = datalabel,
115	22x	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	85x	if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
127	!	stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
128		}
129	85x	SEFilterStates$new(
130	85x	data = data,
131	85x	data_reactive = data_reactive,
132	85x	dataname = dataname,
133	85x	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	198x	is_expected_class <- vapply(
166	198x	X = data,
167	198x	FUN = function(x) any(class(x) %in% .filterable_class),
168	198x	FUN.VALUE = logical(1)
169		)
170	198x	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	29x	is_expected_class <- class(data[, 1]) %in% .filterable_class
178	29x	if (is_expected_class && !is.null(colnames(data))) {
179	26x	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	9x	if (length(choices) == 0) {
216	!	return(character(0))
217		}
218	9x	choice_types <- variable_types(data = data, columns = choices)
219	9x	choice_types[keys] <- "primary_key"
220
221	9x	choices_labeled(
222	9x	choices = choices,
223	9x	labels = unname(varlabels[choices]),
224	9x	types = choice_types[choices]
225		)
226		}
227
228		#' @noRd
229		#' @keywords internal
230		get_varlabels <- function(data) {
231	9x	if (!is.array(data)) {
232	9x	vapply(
233	9x	colnames(data),
234	9x	FUN = function(x) {
235	42x	label <- attr(data[[x]], "label")
236	42x	if (is.null(label)) {
237	40x	x
238		} else {
239	2x	label
240		}
241		},
242	9x	FUN.VALUE = character(1)
243		)
244		} else {
245	!	character(0)
246		}
247		}

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, div(
40		#' h4("ChoicesFilterState"),
41		#' filter_state$ui("fs")
42		#' )),
43		#' column(8, div(
44		#' h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
45		#' textOutput("condition_choices"), br(),
46		#' h4("Unformatted state"), # display raw filter state
47		#' textOutput("unformatted_choices"), br(),
48		#' h4("Formatted state"), # display human readable filter state
49		#' textOutput("formatted_choices"), 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	26x	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 observers stored in `private$observers`.
145		#'
146		#' @return `NULL`, invisibly.
147		#'
148		destroy_observers = function() {
149	!	lapply(private$observers, function(x) x$destroy())
150
151	!	if (!is.null(private$destroy_shiny)) {
152	!	private$destroy_shiny()
153		}
154	!	invisible(NULL)
155		},
156
157		# public shiny modules ----
158
159		#' @description
160		#' `shiny` module server.
161		#'
162		#' @param id (`character(1)`)
163		#' `shiny` module instance id.
164		#'
165		#' @return Reactive expression signaling that the remove button has been clicked.
166		#'
167		server = function(id) {
168	!	moduleServer(
169	!	id = id,
170	!	function(input, output, session) {
171	!	private$server_summary("summary")
172
173	!	private$destroy_shiny <- function() {
174	!	logger::log_trace("Destroying FilterStateExpr inputs; id: { private$get_id() }")
175		# remove values from the input list
176	!	lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
177		}
178
179	!	reactive(input$remove) # back to parent to remove self
180		}
181		)
182		},
183
184		#' @description
185		#' `shiny` module UI.
186		#' The UI for this class contains simple message stating that it is not supported.
187		#' @param id (`character(1)`)
188		#' `shiny` module instance id.
189		#' @param parent_id (`character(1)`)
190		#' id of the `FilterStates` card container.
191		ui = function(id, parent_id = "cards") {
192	!	ns <- NS(id)
193	!	isolate({
194	!	tags$div(
195	!	id = id,
196	!	class = "panel filter-card",
197	!	include_js_files("count-bar-labels.js"),
198	!	tags$div(
199	!	class = "filter-card-header",
200	!	tags$div(
201	!	class = "filter-card-title",
202	!	if (private$is_anchored()) {
203	!	icon("anchor-lock", class = "filter-card-icon")
204		} else {
205	!	icon("lock", class = "filter-card-icon")
206		},
207	!	div(class = "filter-card-varname", tags$strong(private$teal_slice$id)),
208	!	div(class = "filter-card-varlabel", private$teal_slice$title),
209	!	div(
210	!	class = "filter-card-controls",
211	!	if (isFALSE(private$is_anchored())) {
212	!	actionLink(
213	!	inputId = ns("remove"),
214	!	label = icon("circle-xmark", lib = "font-awesome"),
215	!	title = "Remove filter",
216	!	class = "filter-card-remove"
217		)
218		}
219		)
220		),
221	!	tags$div(
222	!	class = "filter-card-summary",
223	!	private$ui_summary(ns("summary"))
224		)
225		)
226		)
227		})
228		}
229		),
230
231		# private members ----
232
233		private = list(
234		observers = NULL, # stores observers
235		teal_slice = NULL, # stores reactiveValues
236		destroy_shiny = NULL, # function is set in server
237
238		# @description
239		# Get id of the teal_slice.
240		# @return `character(1)`
241		get_id = function() {
242	!	isolate(private$teal_slice$id)
243		},
244
245		# Check whether this filter is anchored (cannot be removed).
246		# @return `logical(1)`
247		is_anchored = function() {
248	!	isolate(isTRUE(private$teal_slice$anchored))
249		},
250
251		# @description
252		# Server module to display filter summary
253		# @param id `shiny` id parameter
254		ui_summary = function(id) {
255	!	ns <- NS(id)
256	!	uiOutput(ns("summary"), class = "filter-card-summary")
257		},
258
259		# @description
260		# UI module to display filter summary
261		# @param shiny `id` parameter passed to moduleServer
262		# renders text describing current state
263		server_summary = function(id) {
264	!	moduleServer(
265	!	id = id,
266	!	function(input, output, session) {
267	!	output$summary <- renderUI(private$content_summary())
268		}
269		)
270		},
271		content_summary = function() {
272	!	isolate(private$teal_slice$expr)
273		}
274		)
275		)

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
11	!	invisible()
12		}
13
14		### GLOBAL VARIABLES ###
15
16		.filterable_class <- c("logical", "integer", "numeric", "factor", "character", "Date", "POSIXct", "POSIXlt")
17
18
19		### END GLOBAL VARIABLES ###
20
21
22		### ENSURE CHECK PASSES
23
24		# This function is necessary for check to properly process code dependencies within R6 classes.
25		# If `package` is listed in `Imports` in `DESCRIPTION`,
26		# (1) check goes through `NAMESPACE` looking for any `importFrom(package,<foo>)` statements
27		# or an `import(package)` statement. If none are found,
28		# (2) check looks for `package::*` calls in the code. If none are found again,
29		# (3) check throws a NOTE;
30		# # Namespaces in Imports field not imported from:
31		# # 'package'
32		# # All declared Imports should be used.
33		# This note is banned by our CI.
34		# When package::* statements are made within an R6 class, they are not registered.
35		# This function provides single references to the imported namespaces for check to notice.
36		.rectify_dependencies_check <- function() {
37	!	dplyr::filter
38	!	grDevices::rgb
39	!	htmltools::tagInsertChildren
40	!	lifecycle::badge
41	!	logger::log_trace
42	!	plotly::plot_ly
43	!	shinycssloaders::withSpinner
44	!	shinyWidgets::pickerOptions
45	!	teal.data::datanames
46	!	teal.widgets::optionalSelectInput
47		}
48
49
50		### END ENSURE CHECK PASSES

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, div(
50		#' h4("Active filters"),
51		#' filter_states_df$ui_active("fsdf")
52		#' )),
53		#' column(4, div(
54		#' h4("Manual filter control"),
55		#' filter_states_df$ui_add("add_filters"), br(),
56		#' h4("Condition (i.e. call)"), # display the subset expression generated by this FilterStates
57		#' textOutput("call_df"), br(),
58		#' h4("Formatted state"), # display human readable filter state
59		#' textOutput("formatted_df"), br()
60		#' )),
61		#' column(4, div(
62		#' h4("Programmatic filter control"),
63		#' actionButton("button1_df", "set NUM1 < 30", width = "100%"), br(),
64		#' actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), br(),
65		#' actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"), br(),
66		#' actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), br(),
67		#' actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), br(),
68		#' actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), br(),
69		#' hr(),
70		#' actionButton("button7_df", "remove NUM1", width = "100%"), br(),
71		#' actionButton("button8_df", "remove NUM2", width = "100%"), br(),
72		#' actionButton("button9_df", "remove CHAR1", width = "100%"), br(),
73		#' actionButton("button10_df", "remove CHAR2", width = "100%"), br(),
74		#' actionButton("button11_df", "remove DATE", width = "100%"), br(),
75		#' actionButton("button12_df", "remove DATETIME", width = "100%"), br(),
76		#' hr(),
77		#' actionButton("button0_df", "clear all filters", width = "100%"), 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)`)
178		#' optional 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	103x	checkmate::assert_function(data_reactive, args = "sid")
188	103x	checkmate::assert_data_frame(data)
189	103x	super$initialize(data, data_reactive, dataname, datalabel)
190	103x	private$keys <- keys
191	103x	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		#' 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	9x	checkmate::assert_multi_class(data, c("data.frame", "DataFrame", "matrix"))
40	9x	checkmate::assert_character(columns, any.missing = FALSE, null.ok = TRUE)
41	9x	checkmate::assert_subset(columns, colnames(data))
42
43	9x	if (is.matrix(data)) {
44	!	type <- typeof(data)
45	!	if (type == "double") type <- "numeric"
46	!	types <-
47	!	if (is.null(columns)) {
48	!	stats::setNames(rep_len(type, ncol(data)), nm = colnames(data))
49		} else {
50	!	stats::setNames(rep_len(type, length(columns)), nm = columns)
51		}
52		} else {
53	9x	types <- vapply(data, function(x) class(x)[1L], character(1L))
54	9x	if (!is.null(columns)) types <- types[columns]
55		# alternative after R 4.4.0: `types <- types[columns %\|\|% TRUE]`
56		}
57	9x	types
58		}

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`)
9		#' optional 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		#' @examplesIf requireNamespace("MultiAssayExperiment")
55		#' # MAEFilteredDataset example
56		#' library(shiny)
57		#'
58		#' data(miniACC, package = "MultiAssayExperiment")
59		#'
60		#' MAE_fd <- init_filtered_dataset(miniACC, "MAE")
61		#' ui <- fluidPage(
62		#' MAE_fd$ui_add(id = "add"),
63		#' MAE_fd$ui_active("dataset"),
64		#' verbatimTextOutput("call")
65		#' )
66		#' server <- function(input, output, session) {
67		#' MAE_fd$srv_add(id = "add")
68		#' MAE_fd$srv_active(id = "dataset")
69		#' output$call <- renderText({
70		#' paste(
71		#' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),
72		#' collapse = "\n"
73		#' )
74		#' })
75		#' }
76		#' if (interactive()) {
77		#' shinyApp(ui, server)
78		#' }
79		#'
80		#' @keywords internal
81		#' @export
82		init_filtered_dataset <- function(dataset, # nolint
83		dataname,
84		keys = character(0),
85		parent_name = character(0),
86		parent = reactive(dataset),
87		join_keys = character(0),
88		label = attr(dataset, "label")) {
89	107x	UseMethod("init_filtered_dataset")
90		}
91
92		#' @keywords internal
93		#' @export
94		init_filtered_dataset.data.frame <- function(dataset, # nolint
95		dataname,
96		keys = character(0),
97		parent_name = character(0),
98		parent = NULL,
99		join_keys = character(0),
100		label = attr(dataset, "label")) {
101	83x	DataframeFilteredDataset$new(
102	83x	dataset = dataset,
103	83x	dataname = dataname,
104	83x	keys = keys,
105	83x	parent_name = parent_name,
106	83x	parent = parent,
107	83x	join_keys = join_keys,
108	83x	label = label
109		)
110		}
111
112		#' @keywords internal
113		#' @export
114		init_filtered_dataset.MultiAssayExperiment <- function(dataset, # nolint
115		dataname,
116		keys = character(0),
117		parent_name, # ignored
118		parent, # ignored
119		join_keys, # ignored
120		label = attr(dataset, "label")) {
121	7x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
122	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
123		}
124	7x	MAEFilteredDataset$new(
125	7x	dataset = dataset,
126	7x	dataname = dataname,
127	7x	keys = keys,
128	7x	label = label
129		)
130		}
131
132		#' @keywords internal
133		#' @export
134		init_filtered_dataset.default <- function(dataset, # nolint
135		dataname,
136		keys, # ignored
137		parent_name, # ignored
138		parent, # ignored
139		join_keys, # ignored
140		label = attr(dataset, "label")) {
141	17x	DefaultFilteredDataset$new(
142	17x	dataset = dataset,
143	17x	dataname = dataname,
144	17x	label = label
145		)
146		}

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		#' 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		}