teal.slice coverage - 80.49%

Files
Source

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

  formal_args <- as.list(environment())

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

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

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

  ans
}

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

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

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

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

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

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

  x[c(formal_args, extra_args)]
}


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

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

  jsonify(x_list, trim_lines)
}

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


# format utils -----

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

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

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

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

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

#' Justify colons in `JSON` string
#'
#' This function takes a `JSON` string as input, splits it into lines, and pads element names
#' with spaces so that colons are justified between lines.
#'
#' @param json (`character(1)`) a `JSON` string.
#'
#' @return A list of character strings, which can be collapsed into a `JSON` string.
#'
#' @keywords internal
justify_json <- function(json) {
  format_name <- function(name, name_width) {
    if (nchar(name) == 1 || nchar(gsub("\\s", "", name)) <= 2) {
      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 = " "
      )
    }
  })
}

# MAEFilteredDataset ------

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

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

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

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #' @return `NULL`, invisibly.
    #'
    set_filter_state = function(state) {
      isolate({
        logger::log_debug("FilteredDatasetMAE$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(x) {
          checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname")
        })
        super$set_filter_state(state = state)

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

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

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

        invisible(NULL)
      })
    },

    #' @description
    #' Remove one or more `FilterState` of a `MAEFilteredDataset`.
    #'
    #' @param state (`teal_slices`)
    #'   specifying `FilterState` objects to remove;
    #'   `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored.
    #'
    #' @return `NULL`, invisibly.
    #'
    remove_filter_state = function(state) {
      checkmate::assert_class(state, "teal_slices")

      isolate({
        logger::log_debug("FilteredDatasetMAE$remove_filter_state removing filter(s), dataname: { private$dataname }")
        # remove state on subjects
        subject_state <- Filter(function(x) is.null(x$experiment), state)
        private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state)

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

      invisible(NULL)
    },

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

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

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

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

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

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

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

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

#' 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 <- bslib::page_fluid(
#'   tags$div(
#'     class = "teal-slice 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 equal to `<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 = "teal-slice state-count-container",
    style = "margin-bottom: 5px; padding: 0; margin: 0;",
    `data-bar-id` = inputId,
    tags$svg(
      width = "100%",
      height = "20",
      style = c(
        "display: block;",
        "margin: 0;",
        "padding: 0;",
        "background: white;",
        "box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.1);"
      ),
      tags$rect(
        id = ns("count_bar_unfiltered"),
        x = sprintf("%.2f", countnow / counttotal * 100),
        y = "0",
        width = sprintf("%.2f", (countmax - countnow) / counttotal * 100),
        height = "20",
        fill = "#add8e670"
      ),
      tags$rect(
        id = ns("count_bar_filtered"),
        x = "0",
        y = "0",
        width = sprintf("%.2f", countnow / counttotal * 100),
        height = "20",
        fill = "#add8e6"
      ),
      tags$text(
        id = ns("count_bar_label"),
        x = "2",
        y = "14",
        fill = "#333",
        `font-size` = "12",
        label
      )
    )
  )
}

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

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

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

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

  invisible(NULL)
}

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

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


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

# EmptyFilterState ------

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

  # public methods ----
  public = list(

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

      invisible(self)
    },

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

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


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

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

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

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

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

# FilterState ------

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

  # public methods ----
  public = list(

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

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

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

        private$state_history <- reactiveVal(list())

        invisible(self)
      })
    },

    #' @description Destroys a `FilterState` object.
    destroy = function() private$finalize(),

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

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

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

        invisible(self)
      })
    },


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

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

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

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

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

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

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

          private$session_bindings[[session$ns("remove")]] <- observeEvent(
            once = TRUE, # remove button can be called once, should be destroyed afterwards
            ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI
            eventExpr = input$remove, # when remove button is clicked in the FilterState ui
            handlerExpr = remove_callback()
          )

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

          private$state_history <- reactiveVal(list())

          NULL
        }
      )
    },

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

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

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

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

    # private methods ----

    # setters for state features ----

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

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

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

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

    # getters for state features ----

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

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

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

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

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

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

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

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

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

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

    # other ----

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

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

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

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

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

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

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

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

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

    # shiny modules -----

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

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

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

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

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

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

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

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

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

# 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 <- bslib::page_fluid(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   bslib::layout_column_wrap(
#'     width = 1 / 3,
#'     tags$div(
#'       tags$h4("RangeFilterState"),
#'       fs$ui("fs")
#'     ),
#'     tags$div(
#'       id = "outputs", # div id is needed for toggling the element
#'       tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'       textOutput("condition_range"), tags$br(),
#'       tags$h4("Unformatted state"), # display raw filter state
#'       textOutput("unformatted_range"), tags$br(),
#'       tags$h4("Formatted state"), # display human readable filter state
#'       textOutput("formatted_range"), tags$br()
#'     ),
#'     tags$div(
#'       tags$h4("Programmatic filter control"),
#'       actionButton("button1_range", "set drop NA", width = "100%"), tags$br(),
#'       actionButton("button2_range", "set keep NA", width = "100%"), tags$br(),
#'       actionButton("button3_range", "set drop Inf", width = "100%"), tags$br(),
#'       actionButton("button4_range", "set keep Inf", width = "100%"), tags$br(),
#'       actionButton("button5_range", "set a range", width = "100%"), tags$br(),
#'       actionButton("button6_range", "set full range", width = "100%"), tags$br(),
#'       actionButton("button0_range", "set initial state", width = "100%"), tags$br()
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_range <- renderPrint(fs$get_call())
#'   output$formatted_range <- renderText(fs$format())
#'   output$unformatted_range <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = FALSE))
#'   )
#'   observeEvent(
#'     input$button4_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = TRUE))
#'   )
#'   observeEvent(
#'     input$button5_range,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = c(0.2, 0.74))
#'     )
#'   )
#'   observeEvent(
#'     input$button6_range,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", selected = c(0, 1)))
#'   )
#'   observeEvent(
#'     input$button0_range,
#'     fs$set_state(
#'       teal_slice("data", "variable", selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @keywords internal
#'
RangeFilterState <- R6::R6Class( # nolint
  "RangeFilterState",
  inherit = FilterState,

  # public methods ----
  public = list(

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

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

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

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

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

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

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

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

    # private methods ----

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

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

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

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

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

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

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

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

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

    # shiny modules ----

    # UI Module for `RangeFilterState`.
    # This UI element contains two values for `min` and `max`
    # of the range and two checkboxes whether to keep the `NA` or `Inf`  values.
    # @param id (`character(1)`) `shiny` module instance id.
    ui_inputs = function(id) {
      ns <- NS(id)
      isolate({
        ui_input <- shinyWidgets::numericRangeInput(
          inputId = ns("selection_manual"),
          label = NULL,
          min = private$get_choices()[1L],
          max = private$get_choices()[2L],
          value = private$get_selected(),
          step = private$numeric_step,
          width = "100%"
        )
        tagList(
          tags$div(
            class = "teal-slice choices-state",
            tags$div(
              bslib::tooltip(
                trigger = actionLink(
                  ns("plotly_info"),
                  label = NULL,
                  icon = icon("question-circle")
                ),
                HTML(
                  "<p>
                  Drag vertical lines to set selection.<br>
                  Drag across plot to zoom in.<br>
                  Drag axis to pan.<br>
                  Double click to zoom out."
                )
              ),
              style = "text-align: right; font-size: 0.7em; margin-bottom: -1em; position: relative; z-index: 9;"
            ),
            shinycssloaders::withSpinner(
              plotly::plotlyOutput(ns("plot"), height = "50px"),
              type = 4,
              size = 0.25,
              hide.ui = FALSE
            ),
            ui_input
          ),
          tags$div(
            style = "display: flex; justify-content: space-evenly;",
            private$keep_inf_ui(ns("keep_inf")),
            private$keep_na_ui(ns("keep_na"))
          )
        )
      })
    },

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

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

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

          trigger_event_data <- reactiveVal(NULL)

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

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

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

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

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

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

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


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

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

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

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

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

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

          NULL
        }
      )
    },

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

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

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

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

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

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

        invisible(NULL)
      })
    }
  )
)

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

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

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



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

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

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

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

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

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

# 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 <- bslib::page_fluid(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   bslib::layout_column_wrap(
#'     width = 1 / 3,
#'     tags$div(
#'       tags$h4("LogicalFilterState"),
#'       fs$ui("fs")
#'     ),
#'     tags$div(
#'       id = "outputs", # div id is needed for toggling the element
#'       tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'       textOutput("condition_logical"), tags$br(),
#'       tags$h4("Unformatted state"), # display raw filter state
#'       textOutput("unformatted_logical"), tags$br(),
#'       tags$h4("Formatted state"), # display human readable filter state
#'       textOutput("formatted_logical"), tags$br()
#'     ),
#'     tags$div(
#'       tags$h4("Programmatic filter control"),
#'       actionButton("button1_logical", "set drop NA", width = "100%"), tags$br(),
#'       actionButton("button2_logical", "set keep NA", width = "100%"), tags$br(),
#'       actionButton("button3_logical", "set a selection", width = "100%"), tags$br(),
#'       actionButton("button0_logical", "set initial state", width = "100%"), tags$br()
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_logical <- renderPrint(fs$get_call())
#'   output$formatted_logical <- renderText(fs$format())
#'   output$unformatted_logical <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_logical,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_logical,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_logical,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE))
#'   )
#'   observeEvent(
#'     input$button0_logical,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
LogicalFilterState <- R6::R6Class( # nolint
  "LogicalFilterState",
  inherit = FilterState,

  # public methods ----
  public = list(

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

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

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

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

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

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

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

    # shiny modules ----

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

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

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

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

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

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

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

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

          private$keep_na_srv("keep_na")

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

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

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

          NULL
        }
      )
    },

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

# FilteredData ------

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

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

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

      self$set_available_teal_slices(x = reactive(NULL))

      invisible(self)
    },

    #' @description Destroys a `FilteredData` object.
    destroy = function() private$finalize(),

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

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

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

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

    # datasets methods ----

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

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

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

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

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

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

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

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

      invisible(self)
    },

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

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

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

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

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

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

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

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

        invisible(NULL)
      })

      invisible(NULL)
    },

    #' @description
    #' Removes one or more `FilterState` from a `FilteredData` object.
    #'
    #' @param state (`teal_slices`)
    #'   specifying `FilterState` objects to remove;
    #'   `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored.
    #'
    #' @return `NULL`, invisibly.
    #'
    remove_filter_state = function(state) {
      isolate({
        checkmate::assert_class(state, "teal_slices")
        state_ids <- unique(vapply(state, "[[", character(1L), "id"))
        logger::log_debug("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { state_ids }")
        datanames <- unique(vapply(state, "[[", character(1L), "dataname"))
        checkmate::assert_subset(datanames, self$datanames())
        lapply(datanames, function(dataname) {
          slices <- Filter(function(x) identical(x$dataname, dataname), state)
          private$get_filtered_dataset(dataname)$remove_filter_state(slices)
        })
      })

      invisible(NULL)
    },

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


    # shiny modules -----

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

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

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

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

        NULL
      })
    },

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

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

        private$srv_available_filters("available_filters")

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

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

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

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

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

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

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

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

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

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

        NULL
      })
    },

    #' @description
    #' Creates the UI definition for the module showing counts for each dataset
    #' contrasting the filtered to the full unfiltered dataset.
    #'
    #' Per dataset, it displays
    #' the number of rows/observations in each dataset,
    #' the number of unique subjects.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    ui_overview = function(id) {
      ns <- NS(id)
      tags$div(
        class = "teal-slice",
        bslib::accordion(
          id = ns("main_filter_accordion"),
          bslib::accordion_panel(
            title = "Active Filter Summary",
            tags$div(
              id = ns("filters_overview_contents"),
              tags$div(
                style = "overflow-x: auto;",
                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_function(active_datanames)
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_debug("FilteredData$srv_filter_overview initializing")

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

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

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

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


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

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

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

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

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

          NULL
        }
      )
    }
  ),

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

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

    # activate/deactivate filter panel
    filter_panel_active = TRUE,

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

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

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

    # observers and inputs list
    session_bindings = list(),

    # private methods ----

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

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

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

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

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

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

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

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

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

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

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

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

# 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 <- bslib::page_fluid(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   bslib::layout_column_wrap(
#'     width = 1 / 3,
#'     tags$div(
#'       tags$h4("ChoicesFilterState"),
#'       fs$ui("fs")
#'     ),
#'     tags$div(
#'       tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'       textOutput("condition_choices"), tags$br(),
#'       tags$h4("Unformatted state"), # display raw filter state
#'       textOutput("unformatted_choices"), tags$br(),
#'       tags$h4("Formatted state"), # display human readable filter state
#'       textOutput("formatted_choices"), tags$br()
#'     ),
#'     tags$div(
#'       tags$h4("Programmatic filter control"),
#'       actionButton("button1_choices", "set drop NA", width = "100%"), tags$br(),
#'       actionButton("button2_choices", "set keep NA", width = "100%"), tags$br(),
#'       actionButton("button3_choices", "set selection: a, b", width = "100%"), tags$br(),
#'       actionButton("button4_choices", "deselect all", width = "100%"), tags$br(),
#'       actionButton("button0_choices", "set initial state", width = "100%"), tags$br()
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_choices <- renderPrint(fs$get_call())
#'   output$formatted_choices <- renderText(fs$format())
#'   output$unformatted_choices <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", keep_na = FALSE)
#'     )
#'   )
#'   observeEvent(
#'     input$button2_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", keep_na = TRUE)
#'     )
#'   )
#'   observeEvent(
#'     input$button3_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = c("a", "b"))
#'     )
#'   )
#'   observeEvent(
#'     input$button4_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE)
#'     )
#'   )
#'   observeEvent(
#'     input$button0_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
ChoicesFilterState <- R6::R6Class( # nolint
  "ChoicesFilterState",
  inherit = FilterState,

  # public methods ----

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

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

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

    # private methods ----

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

    # shiny modules ----

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

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

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

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

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

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

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

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

                  if (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()
                    )
                  }

                  private$set_selected(input$selection)
                }
              }
            )
          }

          private$keep_na_srv("keep_na")

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

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

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

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

          NULL
        }
      )
    },

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

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

# FilterStates ------

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

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

      private$dataname <- dataname
      private$datalabel <- datalabel
      private$dataname_prefixed <- if (identical(dataname, make.names(dataname))) {
        dataname
      } else {
        sprintf("`%s`", dataname)
      }
      private$data <- data
      private$data_reactive <- data_reactive
      private$state_list <- reactiveVal()

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

      invisible(self)
    },

    #' @description Destroys a `FilterStates` object.
    destroy = function() private$finalize(),

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

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

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

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

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

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

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

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

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

      fs
    },

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

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

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

        if (length(state) > 0) {
          private$set_filter_state_impl(
            state = state,
            data = private$data,
            data_reactive = private$data_reactive
          )
        }
      })

      invisible(NULL)
    },

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

    # shiny modules ----

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

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

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

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

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

          private$session_bindings[[session$ns("added_states")]] <- observeEvent(
            added_states(), # we want to call FilterState module only once when it's added
            ignoreNULL = TRUE,
            {
              added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L))
              logger::log_debug(
                "{ class(self)[1] }$srv_active@2 triggered by added states: { toString(added_state_names) }"
              )
              lapply(added_states(), function(state) {
                state$server(
                  id = fs_to_shiny_ns(state),
                  remove_callback = function() private$state_list_remove(state$get_state()$id)
                )
              })
              added_states(NULL)
            }
          )

          NULL
        }
      )
    },

    #' @description
    #' `shiny` UI module to add filter variable.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `shiny.tag`
    #'
    ui_add = function(id) {
      checkmate::assert_string(id)
      data <- private$data
      ns <- NS(id)
      if (ncol(data) == 0) {
        tags$div("dataset has no columns")
      } else if (nrow(data) == 0) {
        tags$div("dataset has now rows")
      } else {
        uiOutput(ns("var_to_add_container"))
      }
    },

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

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

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

          output$var_to_add_container <- renderUI({
            logger::log_debug(
              "{ class(self)[1] }$srv_add@1 updating available column choices, dataname: { private$dataname }"
            )
            if (length(avail_column_choices()) == 0) {
              # because input UI is not rendered on this condition but shiny still holds latest selected value
              tags$span("No available columns to add.")
            } else {
              tags$div(
                teal.widgets::optionalSelectInput(
                  session$ns("var_to_add"),
                  choices = avail_column_choices(),
                  selected = NULL,
                  options = shinyWidgets::pickerOptions(
                    liveSearch = TRUE,
                    noneSelectedText = "Select variable to filter"
                  )
                )
              )
            }
          })

          private$session_bindings[[session$ns("var_to_add")]] <- observeEvent(
            eventExpr = input$var_to_add,
            handlerExpr = {
              # We have to close the picker selection dropdown because it is re-rendered with new choices
              # and if the old dropdown is still open, it gets unbinded and cannot be closed.
              shinyjs::runjs(
                sprintf(
                  "document.querySelector('#%s .dropdown').click()",
                  session$ns("var_to_add_input")
                )
              )
              logger::log_debug(
                "{ class(self)[1] }$srv_add@2 adding FilterState for variable { input$var_to_add }, ",
                "dataname {private$dataname}"
              )
              self$set_filter_state(
                teal_slices(
                  teal_slice(dataname = private$dataname, varname = input$var_to_add)
                )
              )
            }
          )

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

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

    # private methods ----

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

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

    # state_list methods ----

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

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

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

    # @description
    # Removes a single filter state with all associated shiny elements:
    # * specified `FilterState` from `private$state_list`
    # * UI card created for this filter
    # * observers tracking the selection and remove button
    #
    # @param state_id (`character`)
    #   identifiers of elements in a filter state (which is a `reactiveVal` containing a list).
    # @param force (`logical(1)`)
    #   flag specifying whether to include anchored filter states.
    #
    # @return `NULL`, invisibly.
    #
    state_list_remove = function(state_id, force = FALSE) {
      isolate({
        checkmate::assert_character(state_id)
        logger::log_debug("{ class(self)[1] }$state_list_remove removing a filter, state_id: { toString(state_id) }")
        current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1))
        to_remove <- state_id %in% current_state_ids
        if (any(to_remove)) {
          new_state_list <- Filter(
            function(state) {
              if (state$get_state()$id %in% state_id) {
                if (state$get_state()$anchored && !force) {
                  TRUE
                } else {
                  state$destroy()
                  FALSE
                }
              } else {
                TRUE
              }
            },
            private$state_list()
          )
          private$state_list(new_state_list)
        } else {
          warning(sprintf("\"%s\" not found in state list", state_id))
        }
      })

      invisible(NULL)
    },

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

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

      invisible(NULL)
    },

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

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

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

        invisible(NULL)
      })
    },

    # @description
    # Object cleanup.
    #
    # - Destroy inputs and observers stored in `private$session_bindings`
    # - Clean `state_list`
    #
    # @return `NULL`, invisibly.
    #
    finalize = function() {
      .finalize_session_bindings(self, private)
    }
  )
)

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

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

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

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

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

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

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


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


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

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


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

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

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


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

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

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

  jsonify(slices_list, trim_lines)
}

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


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

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

# SEFilterStates ------

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

  # public methods ----
  public = list(
    #' @description
    #' Initialize `SEFilterStates` object.
    #'
    #' @param data (`SummarizedExperiment`)
    #'   the `R` object which `subset` function is applied on.
    #' @param data_reactive (`function(sid)`)
    #'   should return a `SummarizedExperiment` object or `NULL`.
    #'   This object is needed for the `FilterState` counts being updated on a change in filters.
    #'   If function returns `NULL` then filtered counts are not shown.
    #'   Function has to have `sid` argument being a character.
    #' @param dataname (`character(1)`)
    #'   name of the data used in the expression
    #'   specified to the function argument attached to this `FilterStates`.
    #' @param datalabel (`character(1)`) optional
    #'   text label. Should be the name of experiment.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL) {
      if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
        stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
      }
      checkmate::assert_function(data_reactive, args = "sid")
      checkmate::assert_class(data, "SummarizedExperiment")
      super$initialize(data, data_reactive, dataname, datalabel)
      if (!is.null(datalabel)) {
        private$dataname_prefixed <- sprintf(
          "%s[['%s']]", private$dataname_prefixed, datalabel
        )
      }
    },

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

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

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

        invisible(NULL)
      })
    },

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

      row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
        tags$div("no gene variables available")
      } else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
        tags$div("no genes available")
      } else {
        uiOutput(ns("row_to_add_container"))
      }

      col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
        tags$div("no sample variables available")
      } else if (nrow(SummarizedExperiment::colData(data)) == 0) {
        tags$div("no samples available")
      } else {
        uiOutput(ns("col_to_add_container"))
      }

      tags$div(row_input, col_input)
    },

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

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

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

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

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

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

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

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

          output$row_to_add_container <- renderUI({
            logger::log_debug(
              "{ class(self)[1] }$srv_add@1 updating available row data choices, dataname: { private$dataname }"
            )
            if (length(avail_row_data_choices()) == 0) {
              # because input UI is not rendered on this condition but shiny still holds latest selected value
              tags$div("no gene variables available")
            } else {
              tags$div(
                teal.widgets::optionalSelectInput(
                  session$ns("row_to_add"),
                  choices = avail_row_data_choices(),
                  selected = NULL,
                  options = shinyWidgets::pickerOptions(
                    liveSearch = TRUE,
                    noneSelectedText = "Select gene variable"
                  )
                )
              )
            }
          })

          output$col_to_add_container <- renderUI({
            logger::log_debug(
              "{ class(self)[1] }$srv_add@1 updating available col data choices, dataname: { private$dataname }"
            )
            if (length(avail_col_data_choices()) == 0) {
              # because input UI is not rendered on this condition but shiny still holds latest selected value
              tags$div("no sample variables available")
            } else {
              tags$div(
                teal.widgets::optionalSelectInput(
                  session$ns("col_to_add"),
                  choices = avail_col_data_choices(),
                  selected = NULL,
                  options = shinyWidgets::pickerOptions(
                    liveSearch = TRUE,
                    noneSelectedText = "Select sample variable"
                  )
                )
              )
            }
          })

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


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

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

          NULL
        }
      )
    }
  )
)

# 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 <- bslib::page_fluid(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   bslib::layout_column_wrap(
#'     width = 1 / 3,
#'     tags$div(
#'       tags$h4("DatetimeFilterState"),
#'       fs$ui("fs")
#'     ),
#'     tags$div(
#'       id = "outputs", # div id is needed for toggling the element
#'       tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'       textOutput("condition_datetime"), tags$br(),
#'       tags$h4("Unformatted state"), # display raw filter state
#'       textOutput("unformatted_datetime"), tags$br(),
#'       tags$h4("Formatted state"), # display human readable filter state
#'       textOutput("formatted_datetime"), tags$br()
#'     ),
#'     tags$div(
#'       tags$h4("Programmatic filter control"),
#'       actionButton("button1_datetime", "set drop NA", width = "100%"), tags$br(),
#'       actionButton("button2_datetime", "set keep NA", width = "100%"), tags$br(),
#'       actionButton("button3_datetime", "set a range", width = "100%"), tags$br(),
#'       actionButton("button4_datetime", "set full range", width = "100%"), tags$br(),
#'       actionButton("button0_datetime", "set initial state", width = "100%"), tags$br()
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_datetime <- renderPrint(fs$get_call())
#'   output$formatted_datetime <- renderText(fs$format())
#'   output$unformatted_datetime <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_datetime,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_datetime,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_datetime,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)])
#'     )
#'   )
#'   observeEvent(
#'     input$button4_datetime,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = datetimes)
#'     )
#'   )
#'   observeEvent(
#'     input$button0_datetime,
#'     fs$set_state(
#'       teal_slice(
#'         dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE
#'       )
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
DatetimeFilterState <- R6::R6Class( # nolint
  "DatetimeFilterState",
  inherit = FilterState,

  # public methods ----

  public = list(

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

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

      invisible(self)
    },

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

  # private members ----

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

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

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

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

      values
    },

    # shiny modules ----

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

      isolate({
        ui_input_1 <- shinyWidgets::airDatepickerInput(
          inputId = ns("selection_start"),
          value = private$get_selected()[1],
          startView = private$get_selected()[1],
          timepicker = TRUE,
          minDate = private$get_choices()[1L],
          maxDate = private$get_choices()[2L],
          update_on = "close",
          addon = "none"
        )
        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"
        )
        ui_reset_1 <- actionButton(
          class = "teal-slice date-reset-button",
          inputId = ns("start_date_reset"),
          label = NULL,
          icon = icon("fas fa-undo")
        )
        ui_reset_2 <- actionButton(
          class = "teal-slice date-reset-button",
          inputId = ns("end_date_reset"),
          label = NULL,
          icon = icon("fas fa-undo")
        )
        ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm"))
        ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm"))

        tags$div(
          tags$div(
            style = "display: flex;",
            ui_reset_1,
            tags$div(
              class = "teal-slice filter_datelike_input",
              style = "display: flex; width: 80%;",
              tags$div(style = "width: 45%; text-align: center;", ui_input_1),
              tags$span(
                style = "width: 10%; height: 3rem !important;",
                tags$span(
                  style = "height: 3rem; display: flex; justify-content: center; align-items: center;",
                  "to"
                ),
                title = "Times are displayed in the local timezone and are converted to UTC in the analysis"
              ),
              tags$div(style = "width: 45%; text-align: center;", ui_input_2)
            ),
            ui_reset_2
          ),
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

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

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


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

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

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

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

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

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

          private$keep_na_srv("keep_na")

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

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

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

          NULL
        }
      )
    },

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

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

# DataframeFilteredDataset ------

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

  # public fields ----
  public = list(

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

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

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

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

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

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

      invisible(self)
    },

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

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

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

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

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

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

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

    #' @description
    #' Remove one or more `FilterState` form a `FilteredDataset`.
    #'
    #' @param state (`teal_slices`)
    #'   specifying `FilterState` objects to remove;
    #'   `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored
    #'
    #' @return `NULL`, invisibly.
    #'
    remove_filter_state = function(state) {
      checkmate::assert_class(state, "teal_slices")

      isolate({
        logger::log_debug(
          "FilteredDatasetDataframe$remove_filter_state removing filter(s), dataname: { private$dataname }"
        )

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

      invisible(NULL)
    },

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

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

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

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

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

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

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

  datasets$remove_filter_state(filter)
  invisible(NULL)
}

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

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

# 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 <- bslib::page_fluid(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   bslib::layout_column_wrap(
#'     width = 1 / 3,
#'     tags$div(
#'       tags$h4("DateFilterState"),
#'       fs$ui("fs")
#'     ),
#'     tags$div(
#'       id = "outputs", # div id is needed for toggling the element
#'       tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'       textOutput("condition_date"), tags$br(),
#'       tags$h4("Unformatted state"), # display raw filter state
#'       textOutput("unformatted_date"), tags$br(),
#'       tags$h4("Formatted state"), # display human readable filter state
#'       textOutput("formatted_date"), tags$br()
#'     ),
#'     tags$div(
#'       tags$h4("Programmatic filter control"),
#'       actionButton("button1_date", "set drop NA", width = "100%"), tags$br(),
#'       actionButton("button2_date", "set keep NA", width = "100%"), tags$br(),
#'       actionButton("button3_date", "set a range", width = "100%"), tags$br(),
#'       actionButton("button4_date", "set full range", width = "100%"), tags$br(),
#'       actionButton("button0_date", "set initial state", width = "100%"), tags$br()
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_date <- renderPrint(fs$get_call())
#'   output$formatted_date <- renderText(fs$format())
#'   output$unformatted_date <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_date,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_date,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_date,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)]))
#'   )
#'   observeEvent(
#'     input$button4_date,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates))
#'   )
#'   observeEvent(
#'     input$button0_date,
#'     fs$set_state(
#'       teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
DateFilterState <- R6::R6Class( # nolint
  "DateFilterState",
  inherit = FilterState,

  # public methods ----

  public = list(

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

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

      invisible(self)
    },

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

  # private methods ----

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

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

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

      values
    },

    # shiny modules ----

    # @description
    # UI Module for `DateFilterState`.
    # This UI element contains two date selections for `min` and `max`
    # of the range and a checkbox whether to keep the `NA` values.
    # @param id (`character(1)`) `shiny` module instance id.
    ui_inputs = function(id) {
      ns <- NS(id)
      isolate({
        tags$div(
          tags$div(
            style = "display: flex;",
            actionButton(
              class = "teal-slice date-reset-button",
              inputId = ns("start_date_reset"),
              label = NULL,
              icon = icon("fas fa-undo")
            ),
            tags$div(
              class = "teal-slice filter_datelike_input",
              style = "width: 80%;",
              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 = "teal-slice date-reset-button",
              inputId = ns("end_date_reset"),
              label = NULL,
              icon = icon("fas fa-undo")
            )
          ),
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

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

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

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

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

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


          private$keep_na_srv("keep_na")

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

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

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

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

          NULL
        }
      )
    },

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

# FilteredDataset abstract --------

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

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

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

    #' @description Destroys a `FilteredDataset` object.
    destroy = function() private$finalize(),


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

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

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

    # managing filter states -----

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

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

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #'
    #' @return Virtual method, returns nothing and raises error.
    #'
    set_filter_state = function(state) {
      isolate({
        allow_add <- attr(state, "allow_add")
        if (!is.null(allow_add) && !identical(allow_add, private$allow_add())) {
          private$allow_add(allow_add)
        }
        invisible(self)
      })
    },

    #' @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) {
      ns <- NS(id)
      uiOutput(ns("container"))
    },
    #' @description
    #' Server module for a dataset active filters.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `NULL`.
    srv_active = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          dataname <- self$get_dataname()
          logger::log_debug("FilteredDataset$srv_active initializing, dataname: { dataname }")

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

          is_displayed <- reactiveVal()
          private$session_bindings[[session$ns("is_displayed")]] <- observe({
            res <- private$allow_add() || filter_count() > 0
            isolate(
              if (!identical(res, is_displayed())) is_displayed(res)
            )
          })

          output$container <- renderUI({
            if (is_displayed()) {
              isolate({
                tags$span(
                  id = session$ns(id),
                  class = "teal-slice",
                  include_css_files("filter-panel"),
                  include_js_files(pattern = "icons"),
                  bslib::accordion(
                    id = session$ns("dataset_filter_accordion"),
                    class = "teal-slice-dataset-filter",
                    bslib::accordion_panel(
                      dataname,
                      style = "padding: 0; margin: 0;",
                      bslib::page_fluid(
                        id = session$ns("whole_ui"),
                        style = "margin: 0; padding: 0;",
                        uiOutput(session$ns("active_filter_badge")),
                        div(
                          id = session$ns("filter_util_icons"),
                          class = "teal-slice filter-util-icons",
                          tags$a(
                            class = "teal-slice filter-icon",
                            tags$i(
                              id = session$ns("add_filter_icon"),
                              class = "fa fa-plus",
                              title = "fold/expand transform panel",
                              onclick = sprintf(
                                "togglePanelItems(this, '%s', 'fa-plus', 'fa-minus');
                                if ($(this).hasClass('fa-minus')) {
                                  $('#%s .accordion-button.collapsed').click();
                                }",
                                session$ns("add_panel"),
                                session$ns("dataset_filter_accordion")
                              )
                            )
                          ),
                          uiOutput(session$ns("filter_util_remove_icons"))
                        ),
                        bslib::page_fluid(
                          style = "padding: 0px; margin: 0;",
                          tags$div(
                            id = session$ns("add_panel"),
                            class = "add-panel",
                            style = "display: none;",
                            self$ui_add(session$ns(private$dataname))
                          )
                        ),
                        tags$div(
                          id = session$ns("filter_count_ui"),
                          style = "display: none;",
                          tagList(
                            textOutput(session$ns("filter_count"))
                          )
                        ),
                        tags$div(
                          # id needed to insert and remove UI to filter single variable as needed
                          # it is currently also used by the above module to entirely hide this panel
                          id = session$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 = session$ns(x)))
                              }
                            )
                          )
                        )
                      )
                    )
                  ),
                  tags$script(
                    HTML(
                      sprintf(
                        "
            $(document).ready(function() {
              $('#%s').appendTo('#%s > .accordion-item > .accordion-header');
              $('#%s > .accordion-item > .accordion-header').css({
                'display': 'flex'
              });
              $('#%s').appendTo('#%s .accordion-header .accordion-title');
            });
          ",
                        session$ns("filter_util_icons"),
                        session$ns("dataset_filter_accordion"),
                        session$ns("dataset_filter_accordion"),
                        session$ns("active_filter_badge"),
                        session$ns("dataset_filter_accordion")
                      )
                    )
                  )
                )
              })
            }
          })

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

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

          output$filter_util_remove_icons <- renderUI({
            if (private$allow_add()) {
              if (length(Filter(function(x) !x$anchored, self$get_filter_state())) > 0) {
                tags$div(
                  style = "display: flex;",
                  actionLink(
                    session$ns("remove_filters"),
                    label = "",
                    icon = icon("far fa-circle-xmark"),
                    class = "teal-slice filter-icon"
                  )
                )
              }
            }
          })

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

          private$session_bindings[[session$ns("get_filter_state")]] <- observeEvent(
            self$get_filter_state(),
            ignoreInit = TRUE,
            {
              shinyjs::hide("filter_count_ui")
              shinyjs::show("filters")
            }
          )

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

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

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

          self$srv_add(private$dataname)

          NULL
        }
      )
    },

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

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

          NULL
        }
      )
    }
  ),
  # private fields ----
  private = list(
    allow_add = NULL, # reactiveVal
    dataset = NULL, # data.frame or MultiAssayExperiment
    data_filtered = NULL,
    data_filtered_fun = NULL, # function
    filter_states = list(),
    dataname = character(0),
    keys = character(0),
    label = character(0),
    session_bindings = list(),

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

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

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

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

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


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

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

  shinyjs::runjs(expr)

  invisible(NULL)
}

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

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

  shinyjs::runjs(expr)

  invisible(NULL)
}

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

# FilterPanelAPI ------

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

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

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

    #' @description
    #' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object.
    #'
    #' @param filter (`teal_slices`)
    #'   specifying `FilterState` objects to remove;
    #'   `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored
    #'
    #' @return `NULL`, invisibly.
    #'
    remove_filter_state = function(filter) {
      private$filtered_data$remove_filter_state(filter)
      invisible(NULL)
    },

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

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

#' 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 <- bslib::page_fluid(
#'   actionButton("clear", tags$span(icon("xmark"), "Remove all filters")),
#'   rf$ui_add(id = "add"),
#'   rf$ui_active("states"),
#'   verbatimTextOutput("expr"),
#' )
#'
#' server <- function(input, output, session) {
#'   rf$srv_add(id = "add")
#'   rf$srv_active(id = "states")
#'   output$expr <- renderText({
#'     deparse1(rf$get_call(), collapse = "\n")
#'   })
#'   observeEvent(input$clear, rf$clear_filter_states())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @export
#'
init_filter_states <- function(data,
                               data_reactive = reactive(NULL),
                               dataname,
                               datalabel = NULL,
                               ...) {
  UseMethod("init_filter_states")
}

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

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

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

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

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

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

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

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

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

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

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

# DefaultFilteredDataset ----

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

  # public methods ----
  public = list(

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

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

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

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

    # shiny modules ----

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

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

#' Set "`<choice>:<label>`" type of names
#'
#' @description
#'
#' 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 types vector containing the types of the columns.
#'
#' @return A named character vector.
#'
#' @keywords internal
#'
choices_labeled <- function(choices, labels, types = NULL) {
  checkmate::assert_character(choices)
  checkmate::assert_character(labels[!is.na(labels)], len = length(choices))
  checkmate::assert_character(types, len = length(choices), null.ok = TRUE)

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

  choices <- structure(
    choices,
    names = combined_labels,
    raw_labels = raw_labels,
    combined_labels = combined_labels,
    class = c("choices_labeled", "character"),
    types = types
  )

  choices
}

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

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

  invisible()
}

### GLOBAL VARIABLES ###

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


### END GLOBAL VARIABLES ###


### ENSURE CHECK PASSES

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


### END ENSURE CHECK PASSES

# FilterStateExpr ------

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

    #' @description Destroys a `FilterStateExpr` object.
    destroy = function() private$finalize(),

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

    # public shiny modules ----

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

          private$session_bindings[[session$ns("remove")]] <- observeEvent(
            once = TRUE, # remove button can be called once, should be destroyed afterwards
            ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI
            eventExpr = input$remove, # when remove button is clicked in the FilterState ui
            handlerExpr = remove_callback()
          )

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

          NULL
        }
      )
    },

    #' @description
    #' `shiny` module UI.
    #'  The UI for this class contains simple message stating that it is not supported.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param parent_id (`character(1)`)
    #'   id of the `FilterStates` card container.
    ui = function(id, parent_id = "cards") {
      ns <- NS(id)
      isolate({
        tags$div(
          id = id,
          class = "teal-slice filter-card",
          include_js_files("count-bar-labels.js"),
          tags$div(
            class = "filter-card-header",
            tags$div(
              class = "teal-slice filter-card-title",
              if (private$is_anchored()) {
                icon("anchor-lock", class = "teal-slice filter-card-icon")
              } else {
                icon("lock", class = "teal-slice filter-card-icon")
              },
              tags$div(class = "teal-slice filter-card-varname", tags$strong(private$teal_slice$id)),
              tags$div(class = "teal-slice filter-card-varlabel", private$teal_slice$title),
              tags$div(
                class = "teal-slice 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 = "teal-slice filter-card-summary",
              private$ui_summary(ns("summary"))
            )
          )
        )
      })
    }
  ),

  # private members ----

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

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

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

    # @description
    # Server module to display filter summary
    # @param id `shiny` id parameter
    ui_summary = function(id) {
      ns <- NS(id)
      uiOutput(ns("summary"), class = "teal-slice 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)
    },

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

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

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

# MatrixFilterStates ------

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

  # public methods ----
  public = list(
    #' @description
    #' Initialize `MatrixFilterStates` object.
    #'
    #' @param data (`matrix`)
    #'   the `R` object which `subset` function is applied on.
    #' @param data_reactive (`function(sid)`)
    #'   should return a `matrix` object or `NULL`.
    #'   This object is needed for the `FilterState` counts being updated on a change in filters.
    #'   If function returns `NULL` then filtered counts are not shown.
    #'   Function has to have `sid` argument being a character.
    #' @param dataname (`character(1)`)
    #'   name of the data used in the subset expression.
    #'   Passed to the function argument attached to this `FilterStates`.
    #' @param datalabel (`character(1)`) optional
    #'   text label. Should be a name of experiment.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL) {
      checkmate::assert_matrix(data)
      super$initialize(data, data_reactive, dataname, datalabel)
      private$set_filterable_varnames(include_varnames = colnames(private$data))
      if (!is.null(datalabel)) {
        private$dataname_prefixed <- sprintf(
          "%s[['%s']]", private$dataname_prefixed, datalabel
        )
      }
    }
  ),
  private = list(
    extract_type = "matrix"
  )
)

#' 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 <- bslib::page_fluid(
#'   iris_fd$ui_add(id = "add"),
#'   iris_fd$ui_active("dataset"),
#'   verbatimTextOutput("call")
#' )
#' server <- function(input, output, session) {
#'   iris_fd$srv_add(id = "add")
#'   iris_fd$srv_active(id = "dataset")
#'
#'   output$call <- renderText({
#'     paste(
#'       vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),
#'       collapse = "\n"
#'     )
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @examples
#' \donttest{
#' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
#'   # MAEFilteredDataset example
#'   library(shiny)
#'
#'   data(miniACC, package = "MultiAssayExperiment")
#'
#'   MAE_fd <- init_filtered_dataset(miniACC, "MAE")
#'   ui <- fluidPage(
#'     MAE_fd$ui_add(id = "add"),
#'     MAE_fd$ui_active("dataset"),
#'     verbatimTextOutput("call")
#'   )
#'   server <- function(input, output, session) {
#'     MAE_fd$srv_add(id = "add")
#'     MAE_fd$srv_active(id = "dataset")
#'     output$call <- renderText({
#'       paste(
#'         vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),
#'         collapse = "\n"
#'       )
#'     })
#'   }
#'   if (interactive()) {
#'     shinyApp(ui, server)
#'   }
#' }
#' }
#' @keywords internal
#' @export
init_filtered_dataset <- function(dataset,
                                  dataname,
                                  keys = character(0),
                                  parent_name = character(0),
                                  parent = reactive(dataset),
                                  join_keys = character(0),
                                  label = attr(dataset, "label", exact = TRUE)) {
  UseMethod("init_filtered_dataset")
}

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

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

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

# 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 <- bslib::page_fluid(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   bslib::layout_column_wrap(
#'     width = 1 / 3,
#'     tags$div(
#'       tags$h4("Active filters"),
#'       filter_states_df$ui_active("fsdf")
#'     ),
#'     tags$div(
#'       tags$h4("Manual filter control"),
#'       filter_states_df$ui_add("add_filters"), tags$br(),
#'       tags$h4("Condition (i.e. call)"), # display the subset expression generated by FilterStates
#'       textOutput("call_df"), tags$br(),
#'       tags$h4("Formatted state"), # display human readable filter state
#'       textOutput("formatted_df"), tags$br()
#'     ),
#'     tags$div(
#'       tags$h4("Programmatic filter control"),
#'       actionButton("button1_df", "set NUM1 < 30", width = "100%"), tags$br(),
#'       actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), tags$br(),
#'       actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"),
#'       tags$br(),
#'       actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), tags$br(),
#'       actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), tags$br(),
#'       actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), tags$br(),
#'       tags$hr(),
#'       actionButton("button7_df", "remove NUM1", width = "100%"), tags$br(),
#'       actionButton("button8_df", "remove NUM2", width = "100%"), tags$br(),
#'       actionButton("button9_df", "remove CHAR1", width = "100%"), tags$br(),
#'       actionButton("button10_df", "remove CHAR2", width = "100%"), tags$br(),
#'       actionButton("button11_df", "remove DATE", width = "100%"), tags$br(),
#'       actionButton("button12_df", "remove DATETIME", width = "100%"), tags$br(),
#'       tags$hr(),
#'       actionButton("button0_df", "clear all filters", width = "100%"), tags$br()
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   filter_states_df$srv_add("add_filters")
#'   filter_states_df$srv_active("fsdf")
#'
#'   output$call_df <- renderPrint(filter_states_df$get_call())
#'   output$formatted_df <- renderText(filter_states_df$format())
#'
#'   observeEvent(input$button1_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30)))
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button2_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21)))
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button3_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D")))
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button4_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F")))
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button5_df, {
#'     filter_state <- teal_slices(
#'       teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02"))
#'     )
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'   observeEvent(input$button6_df, {
#'     filter_state <- teal_slices(
#'       teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
#'     )
#'     filter_states_df$set_filter_state(state = filter_state)
#'   })
#'
#'   observeEvent(input$button7_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "NUM1"))
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button8_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "NUM2"))
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button9_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "CHAR1"))
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button10_df, {
#'     filter_state <- teal_slices(teal_slice("dataset", "CHAR2"))
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button11_df, {
#'     filter_state <- teal_slices(
#'       teal_slice("dataset", "DATE")
#'     )
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'   observeEvent(input$button12_df, {
#'     filter_state <- teal_slices(
#'       teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
#'     )
#'     filter_states_df$remove_filter_state(filter_state)
#'   })
#'
#'   observeEvent(input$button0_df, filter_states_df$clear_filter_states())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @keywords internal
#'
DFFilterStates <- R6::R6Class( # nolint
  classname = "DFFilterStates",
  inherit = FilterStates,

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

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

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

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

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

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 <- bslib::page_fluid(
42		#' tags$div(
43		#' class = "teal-slice 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	36x	checkmate::assert_string(inputId)
76	32x	checkmate::assert_vector(choices)
77	31x	checkmate::assert_numeric(countsmax, len = length(choices))
78	28x	checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)
79	26x	if (!is.null(countsnow)) {
80	8x	checkmate::assert_true(all(countsnow <= countsmax))
81		}
82
83	25x	ns <- NS(inputId)
84
85	25x	mapply(
86	25x	countBar,
87	25x	inputId = ns(seq_along(choices)),
88	25x	label = as.character(choices),
89	25x	countmax = countsmax,
90	25x	countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
91	25x	MoreArgs = list(
92	25x	counttotal = sum(countsmax)
93		),
94	25x	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 equal to `<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	96x	checkmate::assert_string(inputId)
120	92x	checkmate::assert_string(label)
121	89x	checkmate::assert_number(countmax)
122	87x	checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax)
123	85x	checkmate::assert_number(counttotal, lower = countmax)
124
125	83x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
126	83x	ns <- NS(inputId)
127	56x	if (is.null(countnow)) countnow <- 0
128	83x	tags$div(
129	83x	class = "teal-slice state-count-container",
130	83x	style = "margin-bottom: 5px; padding: 0; margin: 0;",
131	83x	`data-bar-id` = inputId,
132	83x	tags$svg(
133	83x	width = "100%",
134	83x	height = "20",
135	83x	style = c(
136	83x	"display: block;",
137	83x	"margin: 0;",
138	83x	"padding: 0;",
139	83x	"background: white;",
140	83x	"box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.1);"
141		),
142	83x	tags$rect(
143	83x	id = ns("count_bar_unfiltered"),
144	83x	x = sprintf("%.2f", countnow / counttotal * 100),
145	83x	y = "0",
146	83x	width = sprintf("%.2f", (countmax - countnow) / counttotal * 100),
147	83x	height = "20",
148	83x	fill = "#add8e670"
149		),
150	83x	tags$rect(
151	83x	id = ns("count_bar_filtered"),
152	83x	x = "0",
153	83x	y = "0",
154	83x	width = sprintf("%.2f", countnow / counttotal * 100),
155	83x	height = "20",
156	83x	fill = "#add8e6"
157		),
158	83x	tags$text(
159	83x	id = ns("count_bar_label"),
160	83x	x = "2",
161	83x	y = "14",
162	83x	fill = "#333",
163	83x	`font-size` = "12",
164	83x	label
165		)
166		)
167		)
168		}
169
170		#' @rdname countBars
171		updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, countsmax, countsnow = NULL) { # nolint
172	16x	checkmate::assert_string(inputId)
173	16x	checkmate::assert_vector(choices)
174	16x	checkmate::assert_numeric(countsmax, len = length(choices))
175	16x	checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)
176
177	16x	ns <- NS(inputId)
178	16x	mapply(
179	16x	updateCountBar,
180	16x	inputId = ns(seq_along(choices)),
181	16x	label = choices,
182	16x	countmax = countsmax,
183	16x	countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
184	16x	MoreArgs = list(
185	16x	counttotal = sum(countsmax)
186		)
187		)
188	16x	invisible(NULL)
189		}
190
191		#' @rdname countBar
192		updateCountBar <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow = NULL, counttotal) { # nolint
193	45x	checkmate::assert_string(inputId)
194	45x	checkmate::assert_string(label)
195	45x	checkmate::assert_number(countmax)
196	45x	checkmate::assert_number(countnow, null.ok = TRUE)
197	45x	checkmate::assert_number(counttotal)
198
199	45x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
200	45x	if (is.null(countnow)) countnow <- countmax
201	45x	session$sendCustomMessage(
202	45x	type = "updateCountBar",
203	45x	message = list(
204	45x	id = session$ns(inputId),
205	45x	label = label,
206	45x	countmax = countmax,
207	45x	countnow = countnow,
208	45x	counttotal = counttotal
209		)
210		)
211
212	45x	invisible(NULL)
213		}
214
215		#' @rdname countBar
216		updateCountText <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow) { # nolint
217	33x	checkmate::assert_string(inputId)
218	33x	checkmate::assert_string(label)
219	33x	checkmate::assert_number(countmax)
220	33x	checkmate::assert_number(countnow, null.ok = TRUE)
221	33x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
222	33x	session$sendCustomMessage(
223	33x	type = "updateCountText",
224	33x	message = list(
225	33x	id = session$ns(inputId),
226	33x	label = label
227		)
228		)
229		}
230
231		#' Build count text
232		#'
233		#' Returns a text label describing filtered counts. The text is composed in the following way:
234		#' - when `countnow` is not `NULL`: `<label> (<countnow>/<countmax>)`
235		#' - when `countnow` is `NULL`: `<label> (<countmax>)`
236		#'
237		#' @param label (`character(1)`) Text displayed before counts.
238		#' @param countnow (`numeric(1)`) Number of filtered counts.
239		#' @param countmax (`numeric(1)`) Number of unfiltered counts.
240		#'
241		#' @return A character string.
242		#'
243		#' @keywords internal
244		#'
245		make_count_text <- function(label, countmax, countnow = NULL) {
246	250x	checkmate::assert_string(label)
247	248x	checkmate::assert_number(countmax)
248	246x	checkmate::assert_number(countnow, null.ok = TRUE)
249	244x	sprintf(
250	244x	"%s (%s%s)",
251	244x	label,
252	244x	if (is.null(countnow)) "" else sprintf("%s/", countnow),
253	244x	countmax
254		)
255		}
256
257
258		#' Adjust counts to match choices
259		#'
260		#' @param choices (`character`) Choices to match.
261		#' @param counts (`named numeric`) Counts to adjust.
262		#' @keywords internal
263		pair_counts <- function(choices, counts) {
264	177x	checkmate::assert_numeric(counts)
265	177x	counts <- counts[match(choices, names(counts))]
266	177x	counts[is.na(counts)] <- 0
267	177x	names(counts) <- choices
268	177x	counts
269		}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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	25x	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	2x	data.frame(dataname = private$dataname, obs = NA, obs_filtered = NA)
91		},
92
93		# shiny modules ----
94
95		#' @description
96		#' Overwrites parent method.
97		#' @details
98		#' Blank UI module that would list active filter states for this dataset.
99		#' @param id (`character(1)`)
100		#' `shiny` module instance id.
101		#' @param allow_add (ignored)
102		#' @return An empty `div`.
103		ui_active = function(id, allow_add) {
104	!	ns <- NS(id)
105	!	tags$div()
106		},
107
108		#' @description
109		#' Overwrites parent method.
110		#' @details
111		#' Blank UI module that would list active filter states for this dataset.
112		#' @param id (`character(1)`)
113		#' `shiny` module instance id.
114		#' @return An empty `div`.
115		ui_add = function(id) {
116	!	ns <- NS(id)
117	!	tags$div()
118		}
119		),
120		private = list(
121		# private methods ----
122		# private fields ----
123		)
124		)

1		#' Set "`<choice>:<label>`" type of names
2		#'
3		#' @description
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 types vector containing the types of the columns.
15		#'
16		#' @return A named character vector.
17		#'
18		#' @keywords internal
19		#'
20		choices_labeled <- function(choices, labels, types = NULL) {
21	42x	checkmate::assert_character(choices)
22	42x	checkmate::assert_character(labels[!is.na(labels)], len = length(choices))
23	39x	checkmate::assert_character(types, len = length(choices), null.ok = TRUE)
24
25	39x	is_dupl <- duplicated(choices)
26	39x	choices <- choices[!is_dupl]
27	39x	labels <- labels[!is_dupl]
28	39x	types <- types[!is_dupl]
29	39x	labels[is.na(labels)] <- "Label Missing"
30	39x	raw_labels <- labels
31	39x	combined_labels <- if (length(choices) > 0) {
32	39x	paste0(choices, ": ", labels)
33		} else {
34	!	character(0)
35		}
36
37	39x	choices <- structure(
38	39x	choices,
39	39x	names = combined_labels,
40	39x	raw_labels = raw_labels,
41	39x	combined_labels = combined_labels,
42	39x	class = c("choices_labeled", "character"),
43	39x	types = types
44		)
45
46	39x	choices
47		}

1		.onLoad <- function(libname, pkgname) { # nolint
2		# adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R
3	!	teal_default_options <- list(teal.threshold_slider_vs_checkboxgroup = 5)
4	!	op <- options()
5	!	toset <- !(names(teal_default_options) %in% names(op))
6	!	if (any(toset)) options(teal_default_options[toset])
7
8		# Set up the teal logger instance
9	!	teal.logger::register_logger("teal.slice")
10	!	teal.logger::register_handlers("teal.slice")
11
12	!	invisible()
13		}
14
15		### GLOBAL VARIABLES ###
16
17		.filterable_class <- c("logical", "integer", "numeric", "factor", "character", "Date", "POSIXct", "POSIXlt")
18
19
20		### END GLOBAL VARIABLES ###
21
22
23		### ENSURE CHECK PASSES
24
25		# This function is necessary for check to properly process code dependencies within R6 classes.
26		# If `package` is listed in `Imports` in `DESCRIPTION`,
27		# (1) check goes through `NAMESPACE` looking for any `importFrom(package,<foo>)` statements
28		# or an `import(package)` statement. If none are found,
29		# (2) check looks for `package::*` calls in the code. If none are found again,
30		# (3) check throws a NOTE;
31		# # Namespaces in Imports field not imported from:
32		# # 'package'
33		# # All declared Imports should be used.
34		# This note is banned by our CI.
35		# When package::* statements are made within an R6 class, they are not registered.
36		# This function provides single references to the imported namespaces for check to notice.
37		.rectify_dependencies_check <- function() {
38	!	dplyr::filter
39	!	grDevices::rgb
40	!	htmltools::tagInsertChildren
41	!	logger::log_debug
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		# 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		#' bslib::layout_column_wrap(
40		#' style = htmltools::css(grid_template_columns = "1fr 2fr"),
41		#' tags$div(
42		#' tags$h4("ChoicesFilterState"),
43		#' filter_state$ui("fs")
44		#' ),
45		#' tags$div(
46		#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
47		#' textOutput("condition_choices"), tags$br(),
48		#' tags$h4("Unformatted state"), # display raw filter state
49		#' textOutput("unformatted_choices"), tags$br(),
50		#' tags$h4("Formatted state"), # display human readable filter state
51		#' textOutput("formatted_choices"), tags$br()
52		#' )
53		#' )
54		#' )
55		#'
56		#' server <- function(input, output, session) {
57		#' filter_state$server("fs")
58		#' output$condition_choices <- renderPrint(filter_state$get_call())
59		#' output$formatted_choices <- renderText(filter_state$format())
60		#' output$unformatted_choices <- renderPrint(filter_state$get_state())
61		#' }
62		#'
63		#' if (interactive()) {
64		#' shinyApp(ui, server)
65		#' }
66		#'
67		#' @keywords internal
68		#'
69		FilterStateExpr <- R6::R6Class( # nolint
70		classname = "FilterStateExpr",
71		# public methods ----
72		public = list(
73		#' @description
74		#' Initialize a `FilterStateExpr` object.
75		#' @param slice (`teal_slice_expr`)
76		#' @return Object of class `FilterStateExpr`, invisibly.
77		#'
78		initialize = function(slice) {
79	22x	checkmate::assert_class(slice, "teal_slice_expr")
80	21x	private$teal_slice <- slice
81	21x	invisible(self)
82		},
83
84		#' @description Destroys a `FilterStateExpr` object.
85	4x	destroy = function() private$finalize(),
86
87		#' @description
88		#' Returns a formatted string representing this `FilterStateExpr` object.
89		#'
90		#' @param show_all (`logical(1)`) passed to `format.teal_slice`
91		#' @param trim_lines (`logical(1)`) passed to `format.teal_slice`
92		#'
93		#' @return `character(1)` the formatted string
94		#'
95		format = function(show_all = FALSE, trim_lines = TRUE) {
96	12x	sprintf(
97	12x	"%s:\n%s",
98	12x	class(self)[1],
99	12x	format(self$get_state(), show_all = show_all, trim_lines = trim_lines)
100		)
101		},
102
103		#' @description
104		#' Prints this `FilterStateExpr` object.
105		#' @param ... arguments passed to the `format` method
106		#' @return `NULL`, invisibly.
107		#'
108		print = function(...) {
109	1x	cat(isolate(self$format(...)))
110		},
111
112		#' @description
113		#' Returns a complete description of this filter state.
114		#'
115		#' @return A `teal_slice` object.
116		#'
117		get_state = function() {
118	132x	private$teal_slice
119		},
120
121		#' @description
122		#' Does nothing. Exists for compatibility.
123		#'
124		#' @param state (`teal_slice`)
125		#'
126		#' @return `self`, invisibly.
127		#'
128		set_state = function(state) {
129	1x	checkmate::assert_class(state, "teal_slice_expr")
130	1x	invisible(self)
131		},
132
133		#' @description
134		#' Get reproducible call.
135		#'
136		#' @param dataname (`ignored`) for a consistency with `FilterState`
137		#'
138		#' Returns reproducible condition call for current selection relevant
139		#' for selected variable type.
140		#' Method is using internal reactive values which makes it reactive
141		#' and must be executed in reactive or isolated context.
142		#'
143		#' @return `call` or `NULL`
144		#'
145		get_call = function(dataname) {
146	3x	isolate(str2lang(private$teal_slice$expr))
147		},
148
149		# public shiny modules ----
150
151		#' @description
152		#' `shiny` module server.
153		#'
154		#' @param id (`character(1)`)
155		#' `shiny` module instance id.
156		#'
157		#' @param remove_callback (`function`)
158		#' callback to handle removal of this `FilterState` object from `state_list`
159		#'
160		#' @return Reactive expression signaling that the remove button has been clicked.
161		#'
162		server = function(id, remove_callback) {
163	7x	moduleServer(
164	7x	id = id,
165	7x	function(input, output, session) {
166	7x	private$server_summary("summary")
167
168	7x	private$session_bindings[[session$ns("remove")]] <- observeEvent(
169	7x	once = TRUE, # remove button can be called once, should be destroyed afterwards
170	7x	ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI
171	7x	eventExpr = input$remove, # when remove button is clicked in the FilterState ui
172	7x	handlerExpr = remove_callback()
173		)
174
175	7x	private$session_bindings[[session$ns("inputs")]] <- list(
176	7x	destroy = function() {
177	6x	logger::log_debug("Destroying FilterState inputs and observers; id: { private$get_id() }")
178	6x	lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
179		}
180		)
181
182	7x	NULL
183		}
184		)
185		},
186
187		#' @description
188		#' `shiny` module UI.
189		#' The UI for this class contains simple message stating that it is not supported.
190		#' @param id (`character(1)`)
191		#' `shiny` module instance id.
192		#' @param parent_id (`character(1)`)
193		#' id of the `FilterStates` card container.
194		ui = function(id, parent_id = "cards") {
195	7x	ns <- NS(id)
196	7x	isolate({
197	7x	tags$div(
198	7x	id = id,
199	7x	class = "teal-slice filter-card",
200	7x	include_js_files("count-bar-labels.js"),
201	7x	tags$div(
202	7x	class = "filter-card-header",
203	7x	tags$div(
204	7x	class = "teal-slice filter-card-title",
205	7x	if (private$is_anchored()) {
206	1x	icon("anchor-lock", class = "teal-slice filter-card-icon")
207		} else {
208	6x	icon("lock", class = "teal-slice filter-card-icon")
209		},
210	7x	tags$div(class = "teal-slice filter-card-varname", tags$strong(private$teal_slice$id)),
211	7x	tags$div(class = "teal-slice filter-card-varlabel", private$teal_slice$title),
212	7x	tags$div(
213	7x	class = "teal-slice filter-card-controls",
214	7x	if (isFALSE(private$is_anchored())) {
215	6x	actionLink(
216	6x	inputId = ns("remove"),
217	6x	label = icon("circle-xmark", lib = "font-awesome"),
218	6x	title = "Remove filter",
219	6x	class = "filter-card-remove"
220		)
221		}
222		)
223		),
224	7x	tags$div(
225	7x	class = "teal-slice filter-card-summary",
226	7x	private$ui_summary(ns("summary"))
227		)
228		)
229		)
230		})
231		}
232		),
233
234		# private members ----
235
236		private = list(
237		session_bindings = list(), # stores observers and inputs to destroy afterwards
238		teal_slice = NULL, # stores reactiveValues
239
240		# @description
241		# Get id of the teal_slice.
242		# @return `character(1)`
243		get_id = function() {
244	!	isolate(private$teal_slice$id)
245		},
246
247		# Check whether this filter is anchored (cannot be removed).
248		# @return `logical(1)`
249		is_anchored = function() {
250	14x	isolate(isTRUE(private$teal_slice$anchored))
251		},
252
253		# @description
254		# Server module to display filter summary
255		# @param id `shiny` id parameter
256		ui_summary = function(id) {
257	7x	ns <- NS(id)
258	7x	uiOutput(ns("summary"), class = "teal-slice filter-card-summary")
259		},
260
261		# @description
262		# UI module to display filter summary
263		# @param shiny `id` parameter passed to moduleServer
264		# renders text describing current state
265		server_summary = function(id) {
266	7x	moduleServer(
267	7x	id = id,
268	7x	function(input, output, session) {
269	7x	output$summary <- renderUI(private$content_summary())
270		}
271		)
272		},
273		content_summary = function() {
274	7x	isolate(private$teal_slice$expr)
275		},
276
277		# @description
278		# Destroy inputs and observers stored in `private$session_bindings`.
279		#
280		# @return `NULL`, invisibly.
281		#
282		finalize = function() {
283	25x	.finalize_session_bindings(self, private)
284		}
285		)
286		)

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	51x	checkmate::assert_list(calls)
31	49x	if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
32	50x	checkmate::assert_string(operator)
33
34	48x	Reduce(
35	48x	x = calls,
36	48x	f = function(x, y) call(operator, x, y)
37		)
38		}

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	42x	checkmate::assert_multi_class(data, c("data.frame", "DataFrame", "matrix"))
40	42x	checkmate::assert_character(columns, any.missing = FALSE, null.ok = TRUE)
41	42x	checkmate::assert_subset(columns, colnames(data))
42
43	42x	if (is.matrix(data)) {
44	1x	type <- typeof(data)
45	1x	if (type == "double") type <- "numeric"
46	1x	types <-
47	1x	if (is.null(columns)) {
48	!	stats::setNames(rep_len(type, ncol(data)), nm = colnames(data))
49		} else {
50	1x	stats::setNames(rep_len(type, length(columns)), nm = columns)
51		}
52		} else {
53	41x	types <- vapply(data, function(x) class(x)[1L], character(1L))
54	41x	if (!is.null(columns)) types <- types[columns]
55		# alternative after R 4.4.0: `types <- types[columns %\|\|% TRUE]`
56		}
57	42x	types
58		}

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

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

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

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	57x	css_files <- list.files(
13	57x	system.file("css", package = "teal.slice", mustWork = TRUE),
14	57x	pattern = pattern, full.names = TRUE
15		)
16	57x	singleton(tags$head(lapply(css_files, includeCSS)))
17		}