teal.slice coverage - 66.06%

Files
Source

#' Initializes `FilteredDataset`
#'
#' @keywords internal
#' @examples
#' # DefaultFilteredDataset example
#' iris_fd <- teal.slice:::init_filtered_dataset(
#'   iris,
#'   dataname = "iris",
#'   metadata = list(type = "teal")
#' )
#' app <- shinyApp(
#'   ui = fluidPage(
#'     iris_fd$ui_add(id = "add"),
#'     iris_fd$ui_active("dataset"),
#'     verbatimTextOutput("call"),
#'     verbatimTextOutput("metadata")
#'   ),
#'   server = function(input, output, session) {
#'     iris_fd$srv_add(id = "add")
#'     iris_fd$srv_active(id = "dataset")
#'
#'     output$metadata <- renderText({
#'       paste("Type =", iris_fd$get_metadata()$type)
#'     })
#'
#'     output$call <- renderText({
#'       paste(
#'         vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),
#'         collapse = "\n"
#'       )
#'     })
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
#'
#' # MAEFilteredDataset example
#' library(MultiAssayExperiment)
#' data(miniACC)
#' MAE_fd <- teal.slice:::init_filtered_dataset(miniACC, "MAE", metadata = list(type = "MAE"))
#' app <- shinyApp(
#'   ui = fluidPage(
#'     MAE_fd$ui_add(id = "add"),
#'     MAE_fd$ui_active("dataset"),
#'     verbatimTextOutput("call"),
#'     verbatimTextOutput("metadata")
#'   ),
#'   server = function(input, output, session) {
#'     MAE_fd$srv_add(id = "add")
#'     MAE_fd$srv_active(id = "dataset")
#'     output$metadata <- renderText({
#'       paste("Type =", MAE_fd$get_metadata()$type)
#'     })
#'     output$call <- renderText({
#'       paste(
#'         vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),
#'         collapse = "\n"
#'       )
#'     })
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
#' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr
#' @param dataname (`character`)\cr
#'  A given name for the dataset it may not contain spaces
#' @param keys optional, (`character`)\cr
#'   Vector with primary keys
#' @param parent_name (`character(1)`)\cr
#'   Name of the parent dataset
#' @param parent (`reactive`)\cr
#'   object returned by this reactive is a filtered `data.frame` from other `FilteredDataset`
#'   named `parent_name`. Consequence of passing `parent` is a `reactive` link which causes
#'   causing re-filtering of this `dataset` based on the changes in `parent`.
#' @param join_keys (`character`)\cr
#'   Name of the columns in this dataset to join with `parent`
#'   dataset. If the column names are different if both datasets
#'   then the names of the vector define the `parent` columns.
#' @param label (`character`)\cr
#'   Label to describe the dataset
#' @param metadata (named `list` or `NULL`) \cr
#'   Field containing metadata about the dataset. Each element of the list
#'   should be atomic and length one.
#' @export
#' @note Although this function is exported for use in other packages, it may be changed or removed in a future release
#'   at which point any code which relies on this exported function will need to be changed.
init_filtered_dataset <- function(dataset, # nolint
                                  dataname,
                                  keys = character(0),
                                  parent_name = character(0),
                                  parent = reactive(dataset),
                                  join_keys = character(0),
                                  label = attr(dataset, "label"),
                                  metadata = NULL) {
  UseMethod("init_filtered_dataset")
}

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

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

#' @name FilterState
#' @docType class
#'
#'
#' @title `FilterState` Abstract Class
#'
#' @description Abstract class to encapsulate single filter state
#'
#' @details
#' This class is responsible for managing single filter item within
#' `FilteredData` class. Filter states depend on the variable type:
#' (`logical`, `integer`, `numeric`, `factor`, `character`, `Date`, `POSIXct`, `POSIXlt`)
#' and returns `FilterState` object with class corresponding to input variable.
#' Class controls single filter entry in `module_single_filter_item` and returns
#' code relevant to selected values.
#' - `factor`, `character`: `class = ChoicesFilterState`
#' - `numeric`: `class = RangeFilterState`
#' - `logical`: `class = LogicalFilterState`
#' - `Date`: `class = DateFilterState`
#' - `POSIXct`, `POSIXlt`: `class = DatetimeFilterState`
#' - all `NA` entries: `class: FilterState`, cannot be filtered
#' - default: `FilterState`, cannot be filtered
#' \cr
#' Each variable's filter state is an `R6` object which contains `choices`,
#' `selected`, `varname`, `dataname`, `labels`, `na_count`, `keep_na` and other
#' variable type specific fields (`keep_inf`, `inf_count`, `timezone`).
#' Object contains also shiny module (`ui` and `server`) which manages
#' state of the filter through reactive values `selected`, `keep_na`, `keep_inf`
#' which trigger `get_call()` and every R function call up in reactive chain.
#' \cr
#' \cr
#' @section Modifying state:
#' Modifying a `FilterState` object is possible in three scenarios:
#' * In the interactive session by passing an appropriate `teal_slice`
#'   to the `set_state` method, or using
#'   `set_selected`, `set_keep_na` or `set_keep_inf` methods.
#' * 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 `InteractiveFilterState` object.
#'
#' @keywords internal
FilterState <- R6::R6Class( # nolint
  "FilterState",

  # public methods ----
  public = list(

    #' @description
    #' Initialize a `FilterState` object
    #' @param x (`vector`)\cr
    #'   values of the variable used in filter
    #' @param x_reactive (`reactive`)\cr
    #'   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`)\cr
    #'   object created by [teal_slice()]
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #' @param ... additional arguments to be saved as a list in `private$extras` field
    #'
    #' @return self invisibly
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          slice,
                          extract_type = character(0)) {
      checkmate::assert_class(x_reactive, "reactive")
      checkmate::assert_class(slice, "teal_slice")
      checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)
      if (length(extract_type) == 1) {
        checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
      }

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

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

      private$state_history <- reactiveVal(list())

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

      invisible(self)
    },

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

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

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

      invisible(self)
    },


    #' @description
    #' Returns filtering 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)`)\cr
    #'   shiny module instance id
    #'
    #' @return `moduleServer` function which returns reactive value
    #'   signaling that remove button has been clicked
    #'
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilterState$server initializing module for slice: { private$get_id() } ")
          private$server_summary("summary")
          if (private$is_fixed()) {
            private$server_inputs_fixed("inputs")
          } else {
            private$server_inputs("inputs")
          }

          private$observers$state <- observeEvent(
            eventExpr = list(private$get_selected(), private$get_keep_na(), private$get_keep_inf()),
            handlerExpr = {
              current_state <- as.list(self$get_state())
              history <- private$state_history()
              history_update <- c(history, list(current_state))
              private$state_history(history_update)
            }
          )

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

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

          private$observers$state_history <- observeEvent(
            eventExpr = private$state_history(),
            handlerExpr = {
              shinyjs::delay(
                ms = 100,
                expr = shinyjs::toggleElement(id = "back", condition = length(private$state_history()) > 1L)
              )
              shinyjs::delay(
                ms = 100,
                expr = shinyjs::toggleElement(id = "reset", condition = length(private$state_history()) > 1L)
              )
            }
          )

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

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

          reactive(input$remove)
        }
      )
    },

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

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

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

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

    # private methods ----

    ## setters for state features ----

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

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

      invisible(NULL)
    },

    # @description
    # Set whether to keep NAs.
    #
    # @param value `logical(1)`\cr
    #   value(s) which come from the filter selection. Value is set in `server`
    #   modules after selecting check-box-input in the shiny interface. Values are set to
    #   `private$teal_slice$keep_na`
    #
    # @return NULL invisibly
    #
    set_keep_na = function(value) {
      checkmate::assert_flag(value)
      private$teal_slice$keep_na <- value
      logger::log_trace(
        sprintf(
          "%s$set_keep_na set for filter %s to %s.",
          class(self)[1],
          private$get_id(),
          value
        )
      )
      invisible(NULL)
    },

    # @description
    # Set whether to keep Infs
    #
    # @param value (`logical(1)`)\cr
    #  Value(s) which come from the filter selection. Value is set in `server`
    #  modules after selecting check-box-input in the shiny interface. Values are set to
    #  `private$teal_slice$keep_inf`
    #
    set_keep_inf = function(value) {
      checkmate::assert_flag(value)
      private$teal_slice$keep_inf <- value
      logger::log_trace(
        sprintf(
          "%s$set_keep_inf of filter %s set to %s",
          class(self)[1],
          private$get_id(),
          value
        )
      )

      invisible(NULL)
    },

    ## getters for state features ----

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

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

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

    # @description
    # Get allowed values from `FilterState`.
    # @return class of the returned object depends of class of the `FilterState`
    get_choices = function() {
      shiny::isolate(private$teal_slice$choices)
    },

    # @description
    # Get selected values from `FilterState`.
    # @return class of the returned object depends of class of the `FilterState`
    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() {
      shiny::isolate(isTRUE(private$teal_slice$fixed))
    },

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

    # Check whether this filter is capable of selecting multiple values.
    # @return `logical(1)`
    is_multiple = function() {
      shiny::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 a character string representation of a subset 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)` before existing condition calls if `keep_na` is selected.
    # Otherwise, if missing values are found in the variable `!is.na` will be added
    # only if `private$na_rm = TRUE`
    # @param filter_call `call` raw filter call, as defined by selection
    # @param varname `character(1)` name of a variable
    # @return a `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
    # 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 (!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 `shiny` id parameter
    ui_summary = function(id) {
      ns <- NS(id)
      uiOutput(ns("summary"), class = "filter-card-summary")
    },

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

    # 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 string specifying this `shiny` module instance
    ui_inputs_fixed = function(id) {
      ns <- NS(id)
      div(
        class = "choices_state",
        uiOutput(ns("selection"))
      )
    },

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

    # @description
    # module displaying input to keep or remove NA in the FilterState call
    # @param id `shiny` id parameter
    #  renders checkbox input only when variable from which FilterState has
    #  been created has some NA values.
    keep_na_ui = function(id) {
      ns <- NS(id)
      if (private$na_count > 0) {
        shiny::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()
          )
          div(
            uiOutput(ns("trigger_visible"), inline = TRUE),
            ui_input
          )
        })
      } else {
        NULL
      }
    },

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

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

#' @title `FilterStates` R6 class
#'
#' @description
#' Abstract class that manages adding and removing `FilterState` objects
#' and builds a \emph{subset expression}.
#'
#' A `FilterStates` object tracks all subsetting expressions
#' (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 \emph{subset expression}.
#'
#' The \emph{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.
    #'
    #' Initializes `FilterStates` object by setting
    #' `dataname`, and `datalabel`.
    #'
    #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr
    #'   the R object which `subset` function is applied on.
    #' @param data_reactive (`function(sid)`)\cr
    #'   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)`)\cr
    #'   name of the data used in the expression
    #'   specified to the function argument attached to this `FilterStates`
    #' @param datalabel (`NULL` or `character(1)`)\cr
    #'   text label value
    #'
    #' @return
    #' self invisibly
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL) {
      checkmate::assert_string(dataname)
      logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
      checkmate::assert_function(data_reactive, args = "sid")
      checkmate::assert_string(datalabel, null.ok = TRUE)

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

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

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

    #' @description
    #' Filter call
    #'
    #' Builds \emph{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`)\cr
    #'  when specified then method returns code containing filter conditions of
    #'  `FilterState` objects which `"sid"` attribute is different than this `sid` argument.
    #'
    #' @return `call` or `NULL`
    #'
    get_call = function(sid = "") {
      logger::log_trace("FilterStates$get_call initializing")

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

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

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

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

    #' @description
    #' Remove one or more `FilterState`s from the `state_list` along with their UI elements.
    #'
    #' @param state (`teal_slices`)\cr
    #'   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")
      shiny::isolate({
        state_ids <- vapply(state, `[[`, character(1), "id")
        logger::log_trace("{ class(self)[1] }$remove_filter_state removing filters, state_id: { toString(state_ids) }")
        private$state_list_remove(state_ids)
      })
      invisible(NULL)
    },

    #' @description
    #' Gets reactive values from active `FilterState` objects.
    #'
    #' Get active filter state from `FilterState` objects stored in `state_list`(s).
    #' The output is a list compatible with input to `self$set_filter_state`.
    #'
    #' @return `list` containing `list` per `FilterState` in the `state_list`
    #'
    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
        )
      }

      return(fs)
    },

    #' @description
    #' Sets active `FilterState` objects.
    #'
    #' @param data (`data.frame`)\cr
    #'   data which are supposed to be filtered
    #' @param state (`named list`)\cr
    #'   should contain values which are initial selection in the `FilterState`.
    #'   Names of the `list` element should correspond to the name of the
    #'   column in `data`.
    #' @return function which throws an error
    set_filter_state = function(state) {
      shiny::isolate({
        logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(x) {
          checkmate::assert_true(
            x$dataname == private$dataname,
            .var.name = "dataname matches private$dataname"
          )
        })

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

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

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

      invisible(NULL)
    },

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

    # shiny modules ----

    #' @description
    #' Shiny module UI
    #'
    #' Shiny UI element that stores `FilterState` UI elements.
    #' Populated with elements created with `renderUI` in the module server.
    #'
    #' @param id (`character(1)`)\cr
    #'   shiny element (module instance) id
    #'
    #' @return `shiny.tag`
    #'
    ui_active = function(id) {
      ns <- NS(id)
      tagList(
        teal.slice:::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)`)\cr
    #'   shiny module instance id
    #'
    #' @return `moduleServer` function which returns `NULL`
    #'
    srv_active = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilterState$srv_active initializing, dataname: { private$dataname }")
          current_state <- reactive(private$state_list_get())
          previous_state <- reactiveVal(NULL) # FilterState list
          added_states <- reactiveVal(NULL) # FilterState list

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

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

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

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

          NULL
        }
      )
    },

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

      ns <- NS(id)

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

    #' @description
    #' Shiny server module to add filter variable.
    #'
    #' This module controls available choices to select as a filter variable.
    #' Once selected, a variable is removed from available choices.
    #' Removing a filter variable adds it back to available choices.
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #'
    #' @return `moduleServer` function which returns `NULL`
    srv_add = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilterStates$srv_add initializing, dataname: { private$dataname }")

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

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


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

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

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

    # private methods ----

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

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

    # state_list methods ----

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

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

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

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

      invisible(NULL)
    },

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

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

      invisible(NULL)
    },

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

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

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

      invisible(NULL)
    }
  )
)

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

  formal_args <- as.list(environment())

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

    formal_args$fixed <- TRUE
    ts_expr_args <- c("dataname", "id", "expr", "fixed", "anchored", "title")
    formal_args <- formal_args[ts_expr_args]
    ans <- do.call(shiny::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(...))
    if (missing(id)) {
      args$id <- get_default_slice_id(args)
    } else {
      checkmate::assert_string(id)
    }
    ans <- do.call(shiny::reactiveValues, args)
    class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
  } else {
    stop("Must provide either `expr` or `varname`.")
  }

  ans
}

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

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

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

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

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

  x[c(formal_args, extra_args)]
}


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

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

  jsonify(x_list, trim_lines)
}

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


# format utils -----

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

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

#' Converts a list to a `JSON` string
#'
#' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string.
#' Ensures proper unboxing of list elements.
#' This function is used by the `format` methods for `teal_slice` and `teal_slices`.
#' @param x `list`, possibly recursive, obtained from `teal_slice` or `teal_slices`.
#' @return A `JSON` string.
#' @keywords internal
#
#' @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(x[[var]])
      }
      lapply(x, no_unbox)
    } else {
      x
    }
  }

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

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

#' Trim Lines in `JSON` String
#'
#' This function takes a `JSON` string as input and returns a modified version of the
#' input where the values portion of each line is trimmed for a less messy console output.
#'
#' @param x A character string.
#'
#' @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
#'
#' 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"))
  shiny::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 = " "
      )
    }
  })
}

#' Progress bars with labels
#'
#' `shiny` element showing progress bar counts. Each element can have an
#' unique `id` attribute so each can be used independently.
#' Progress bar size is dependent on the ratio `choicesnow[i] / countsmax[i]`.
#' Label is `choices[i] (countsnow[i]/countsmax)`
#' @param session (`session`) object passed to function given to `shinyServer`.
#' @param inputId (`character(1)`) `shiny` id
#' @param choices (`vector`) determines label text.
#' @param countsmax (`numeric`) determining maximal count of each element.
#'  Length should be the same as `choices`.
#' @param countsnow (`numeric`) actual counts of each element.
#'  Length should be the same as `choices`.
#' @return list of `shiny.tag`
#' @examples
#'
#' choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE)
#' counts <- table(choices)
#' labels <- teal.slice:::countBars(
#'   inputId = "counts",
#'   choices = c("a", "b", "c"),
#'   countsmax = counts,
#'   countsnow = unname(counts)
#' )
#'
#' app <- shinyApp(
#'   ui = fluidPage(
#'     div(
#'       class = "choices_state",
#'       teal.slice:::include_js_files("count-bar-labels.js"),
#'       teal.slice:::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
#'       teal.slice:::updateCountBars(
#'         inputId = "counts",
#'         choices = levels(choices),
#'         countsmax = counts,
#'         countsnow = unname(new_counts)
#'       )
#'     })
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
#' @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)
  counttotal <- sum(countsmax)

  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
#'
#' Progress bar with label
#' @param session (`session`) object passed to function given to `shinyServer`.
#' @param inputId (`character(1)`) `shiny` id
#' @param label (`character(1)`) Text to display followed by counts
#' @param countmax (`numeric(1)`) maximal possible count for a single item.
#' @param countnow (`numeric(1)`) current count of a single item.
#' @param counttotal (`numeric(1)`) total count to make whole progress bar
#'  taking part of the container. Ratio between `countmax / counttotal`
#'  determines `<style="width: <countmax / counttotal>%""`.
#' @return `shiny.tag` object with a progress bar and a label.
#' @keywords internal
countBar <- function(inputId, label, countmax, countnow = NULL, counttotal = countmax) { # nolint
  checkmate::assert_string(inputId)
  checkmate::assert_string(label)
  checkmate::assert_number(countmax)
  checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax)
  checkmate::assert_number(counttotal, lower = countmax)

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

#' @rdname countBars
updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, # nolint
                            countsmax, countsnow = NULL) {
  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, # nolint
                           countmax, countnow = NULL, counttotal) {
  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
    )
  )
}

#' Make a count text
#'
#' Returns a text 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)`) filtered counts
#' @param countmax (`numeric(1)`) unfiltered counts
#' @return `character(1)`
#' @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
  )
}

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

  # public methods ----
  public = list(

    #' @description
    #' Initialize `EmptyFilterState` object.
    #'
    #' @param x (`vector`)\cr
    #'   values of the variable used in filter
    #' @param x_reactive (`reactive`)\cr
    #'   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`)\cr
    #'   object created using [teal_slice()]. `teal_slice` is stored
    #'   in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`
    #'   returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`
    #'   is a `reactiveValues` which means that changes in particular object are automatically
    #'   reflected in all places which refer to the same `teal_slice`.
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by `dataname`. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #' @param ... additional arguments to be saved as a list in `private$extras` field
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          extract_type = character(0),
                          slice) {
      shiny::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)`)\cr
    #   shiny element (module instance) id
    #
    ui_inputs = function(id) {
      ns <- NS(id)
      shiny::isolate({
        fluidRow(
          div(
            class = "relative",
            div(
              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)`)\cr
    #   shiny module instance id
    #
    # @return `moduleServer` function which returns `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({
            div(
              class = "relative",
              div(
                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")
    }
  )
)

#' @name FilteredData
#' @docType class
#'
#' @title Class to encapsulate filtered datasets
#'
#' @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`
#' 3. `varname`: one of the columns in a dataset
#'
#' @keywords internal
#'
#' @examples
#' library(shiny)
#' datasets <- teal.slice:::FilteredData$new(
#'   list(
#'     iris = list(dataset = iris),
#'     mtcars = list(dataset = mtcars)
#'   )
#' )
#'
#' # get datanames
#' datasets$datanames()
#'
#' datasets$set_filter_state(
#'   teal_slices(teal_slice(dataname = "iris", varname = "Species", selected = "virginica"))
#' )
#' isolate(datasets$get_call("iris"))
#'
#' datasets$set_filter_state(
#'   teal_slices(teal_slice(dataname = "mtcars", varname = "mpg", selected = c(15, 20)))
#' )
#'
#' isolate(datasets$get_filter_state())
#' isolate(datasets$get_call("iris"))
#' isolate(datasets$get_call("mtcars"))
#'
FilteredData <- R6::R6Class( # nolint
  "FilteredData",
  ## __Public Methods ====
  public = list(
    #' @description
    #' Initialize a `FilteredData` object
    #' @param data_objects (`list`)
    #'   should named elements containing `data.frame` or `MultiAssayExperiment`.
    #'   Names of the list will serve as `dataname`.
    #' @param join_keys (`JoinKeys` or NULL) see [`teal.data::join_keys()`].
    #' @param code (`CodeClass` or `NULL`) see [`teal.data::CodeClass`].
    #' @param check (`logical(1)`) whether data has been check against reproducibility.
    #'
    initialize = function(data_objects, join_keys = teal.data::join_keys(), code = NULL, check = FALSE) {
      checkmate::assert_list(data_objects, any.missing = FALSE, min.len = 0, names = "unique")
      # Note the internals of data_objects are checked in set_dataset
      checkmate::assert_class(join_keys, "JoinKeys")
      checkmate::assert_class(code, "CodeClass", null.ok = TRUE)
      checkmate::assert_flag(check)

      self$set_check(check)
      if (!is.null(code)) {
        self$set_code(code)
      }

      self$set_join_keys(join_keys)

      child_parent <- sapply(
        names(data_objects),
        function(i) join_keys$get_parent(i),
        USE.NAMES = TRUE,
        simplify = FALSE
      )
      ordered_datanames <- topological_sort(child_parent)

      for (dataname in ordered_datanames) {
        ds_object <- data_objects[[dataname]]
        validate_dataset_args(ds_object, dataname)
        if (inherits(ds_object, c("data.frame", "MultiAssayExperiment"))) {
          self$set_dataset(
            data = ds_object,
            dataname = dataname
          )
        } else {
          # custom support for TealData object which pass metadata and label also
          # see init_filtered_data.TealData
          self$set_dataset(
            data = ds_object$dataset,
            dataname = dataname,
            metadata = ds_object$metadata,
            label = ds_object$label
          )
        }
      }

      self$set_available_teal_slices(x = reactive(NULL))

      invisible(self)
    },

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

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

    #' Set list of external filter states available for activation.
    #'
    #' 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`,
    #' 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`)\cr
    #'  should return `teal_slices`
    #' @return invisible `NULL`
    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)
    },

    #' Get list of filter states available for this object.
    #'
    #' 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.
    #'
    #' 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 (`call` or `list` of calls) to filter dataset calls
    #'
    get_call = function(dataname) {
      checkmate::assert_subset(dataname, self$datanames())
      private$get_filtered_dataset(dataname)$get_call()
    },

    #' @description
    #' Gets the R preprocessing code string that generates the unfiltered datasets.
    #'
    #' @param dataname (`character(1)`) name(s) of dataset(s)
    #'
    #' @return (`character(1)`) deparsed code
    #'
    get_code = function(dataname = self$datanames()) {
      if (!is.null(private$code)) {
        paste0(private$code$get_code(dataname), collapse = "\n")
      } else {
        paste0("# No pre-processing code provided")
      }
    },

    #' @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`) whether to return a filtered or unfiltered dataset
    #'
    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
    #' Returns whether the datasets in the object has undergone a reproducibility check.
    #'
    #' @return `logical`
    #'
    get_check = function() {
      private$.check
    },

    #' @description
    #' Gets metadata for a given dataset.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #'
    #' @return value of metadata for given data (or `NULL` if it does not exist)
    #'
    get_metadata = function(dataname) {
      checkmate::assert_subset(dataname, self$datanames())
      private$get_filtered_dataset(dataname)$get_metadata()
    },

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

    #' @description
    #' Get filter overview table in form of X (filtered) / Y (non-filtered).
    #'
    #' This is intended to be presented in the application.
    #' The content for each of the data names is defined in `get_filter_overview_info` method.
    #'
    #' @param datanames (`character` vector) names of the dataset
    #'
    #' @return (`matrix`) matrix of observations and subjects of all datasets
    #'
    get_filter_overview = function(datanames) {
      rows <- lapply(
        datanames,
        function(dataname) {
          private$get_filtered_dataset(dataname)$get_filter_overview()
        }
      )
      dplyr::bind_rows(rows)
    },

    #' @description
    #' Get keys for the dataset.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #'
    #' @return (`character`) keys of dataset
    #'
    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 `JoinKeys` 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 `FilteredDatasetDefault` constructor.
    #'
    #' @param data (`data.frame`, `MultiAssayExperiment`)\cr
    #'   data to be filtered.
    #'
    #' @param dataname (`string`)\cr
    #'   the name of the `dataset` to be added to this object
    #'
    #' @param metadata (named `list` or `NULL`) \cr
    #'   Field containing metadata about the dataset. Each element of the list
    #'   should be atomic and length one.
    #'
    #' @param label (`character(1)`)\cr
    #'   Label to describe the dataset
    #' @return (`self`) invisibly this `FilteredData`
    #'
    set_dataset = function(data, dataname, metadata, label) {
      logger::log_trace("FilteredData$set_dataset setting dataset, name: { dataname }")
      # to include it nicely in the Show R Code;
      # the UI also uses `datanames` in ids, so no whitespaces allowed
      check_simple_name(dataname)

      join_keys <- self$get_join_keys()
      parent_dataname <- join_keys$get_parent(dataname)
      if (length(parent_dataname) == 0) {
        private$filtered_datasets[[dataname]] <- init_filtered_dataset(
          dataset = data,
          dataname = dataname,
          metadata = metadata,
          label = label,
          keys = self$get_join_keys()$get(dataname, dataname)
        )
      } else {
        private$filtered_datasets[[dataname]] <- init_filtered_dataset(
          dataset = data,
          dataname = dataname,
          keys = join_keys$get(dataname, dataname),
          parent_name = parent_dataname,
          parent = reactive(self$get_data(parent_dataname, filtered = TRUE)),
          join_keys = self$get_join_keys()$get(dataname, parent_dataname),
          label = label,
          metadata = metadata
        )
      }

      invisible(self)
    },

    #' @description
    #' Set the `join_keys`.
    #'
    #' @param join_keys (`JoinKeys`) join_key (converted to a nested list)
    #'
    #' @return (`self`) invisibly this `FilteredData`
    #'
    set_join_keys = function(join_keys) {
      checkmate::assert_class(join_keys, "JoinKeys")
      private$join_keys <- join_keys
      invisible(self)
    },

    #' @description
    #' Sets whether the datasets in the object have undergone a reproducibility check.
    #'
    #' @param check (`logical`) whether datasets have undergone reproducibility check
    #'
    #' @return (`self`)
    #'
    set_check = function(check) {
      checkmate::assert_flag(check)
      private$.check <- check
      invisible(self)
    },

    #' @description
    #' Sets the R preprocessing code for single dataset.
    #'
    #' @param code (`CodeClass`)\cr
    #'   preprocessing code that can be parsed to generate the unfiltered datasets
    #'
    #' @return (`self`)
    #'
    set_code = function(code) {
      checkmate::assert_class(code, "CodeClass")
      logger::log_trace("FilteredData$set_code setting code")
      private$code <- code
      invisible(self)
    },

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

    #' @description
    #' Gets states of all active `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) {
      sprintf(
        "%s:\n%s",
        class(self)[1],
        format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)
      )
    },

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

    #' @description
    #' Sets active filter states.
    #'
    #' @param state either a `named list` list of filter selections
    #'              or a `teal_slices` object\cr
    #'              specification by list will be deprecated soon
    #'
    #' @return `NULL` invisibly
    #'
    #' @examples
    #' utils::data(miniACC, package = "MultiAssayExperiment")
    #'
    #' datasets <- teal.slice:::FilteredData$new(
    #'   list(iris = list(dataset = iris),
    #'        mae = list(dataset = 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, datalabel = "RPPAArray", arg = "subset")
    #'   )
    #' datasets$set_filter_state(state = fs)
    #' shiny::isolate(datasets$get_filter_state())
    #'
    set_filter_state = function(state) {
      shiny::isolate({
        logger::log_trace("{ class(self)[1] }$set_filter_state initializing")
        if (!is.teal_slices(state)) {
          warning(
            paste(
              "From FilteredData$set_filter_state:",
              "Specifying filters as lists is obsolete and will be deprecated in the next release.",
              "Please see ?set_filter_state and ?teal_slices for details."
            ),
            call. = FALSE
          )
          state <- list_to_teal_slices(state)
        }

        checkmate::assert_class(state, "teal_slices")
        allow_add <- attr(state, "allow_add")
        if (!is.null(allow_add)) {
          private$allow_add <- allow_add
        }

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

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

      invisible(NULL)
    },

    #' @description
    #' Removes one or more `FilterState` from a `FilteredData` object.
    #'
    #' @param state (`teal_slices`)\cr
    #'   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) {
      shiny::isolate({
        if (!is.teal_slices(state)) {
          warning(
            paste(
              "From FilteredData$remove_filter_state:",
              "Specifying filters as lists is obsolete and will be deprecated in the next release.",
              "Please see ?set_filter_state and ?teal_slices for details."
            ),
            call. = FALSE
          )
          state <- list_to_teal_slices(state)
        }

        checkmate::assert_class(state, "teal_slices")
        datanames <- unique(vapply(state, "[[", character(1L), "dataname"))
        checkmate::assert_subset(datanames, self$datanames())

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

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

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

      invisible(NULL)
    },

    #' @description
    #' Remove all `FilterStates` of a `FilteredDataset` or all `FilterStates`
    #' of a `FilteredData` object.
    #'
    #' @param datanames (`character`)\cr
    #'   `datanames` to remove their `FilterStates` or empty which removes
    #'   all `FilterStates` in the `FilteredData` object
    #' @param force (`logical(1)`)\cr
    #'   include locked filter states
    #'
    #' @return `NULL` invisibly
    #'
    clear_filter_states = function(datanames = self$datanames(), force = FALSE) {
      logger::log_trace(
        "FilteredData$clear_filter_states called, datanames: { toString(datanames) }"
      )

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

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

      invisible(NULL)
    },


    # shiny modules -----

    #' Module for the right filter panel in the teal app
    #' with a filter overview panel and a filter variable panel.
    #'
    #' This panel contains info about the number of observations left in
    #' the (active) datasets and allows to filter the datasets.
    #'
    #' @param id (`character(1)`)\cr
    #'   module id
    #' @return `shiny.tag`
    ui_filter_panel = function(id) {
      ns <- NS(id)
      div(
        id = ns(NULL), # used for hiding / showing
        include_css_files(pattern = "filter-panel"),
        self$ui_overview(ns("overview")),
        self$ui_active(ns("active")),
        if (private$allow_add) {
          self$ui_add(ns("add"))
        }
      )
    },

    #' Server function for filter panel
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param active_datanames `function / 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 `moduleServer` function which returns `NULL`
    srv_filter_panel = function(id, active_datanames = self$datanames) {
      checkmate::assert_function(active_datanames)
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilteredData$srv_filter_panel initializing")

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

          self$srv_overview("overview", active_datanames_resolved)
          self$srv_active("active", active_datanames_resolved)
          if (private$allow_add) {
            self$srv_add("add", active_datanames_resolved)
          }

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

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

    #' @description
    #' Server module responsible for displaying active filters.
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param active_datanames (`reactive`)\cr
    #'   defining subset of `self$datanames()` to be displayed.
    #' @return `moduleServer` returning `NULL`
    srv_active = function(id, active_datanames = self$datanames) {
      checkmate::assert_function(active_datanames)
      shiny::moduleServer(id, function(input, output, session) {
        logger::log_trace("FilteredData$srv_active initializing")

        private$srv_available_filters("available_filters")

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

        observeEvent(private$get_filter_count(), {
          shinyjs::toggle("remove_all_filters", condition = private$get_filter_count() != 0)
          shinyjs::show("filter_active_vars_contents")
          shinyjs::hide("filters_active_count")
          toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"), TRUE)
          toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"), TRUE)
        })

        observeEvent(active_datanames(), {
          lapply(self$datanames(), function(dataname) {
            if (dataname %in% active_datanames()) {
              shinyjs::show(dataname)
            } else {
              shinyjs::hide(dataname)
            }
          })
        })

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

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

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

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

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

        observeEvent(active_datanames(), {
          lapply(self$datanames(), function(dataname) {
            if (dataname %in% active_datanames()) {
              shinyjs::show(dataname)
            } else {
              shinyjs::hide(dataname)
            }
          })
        })

        # should not use for-loop as variables are otherwise only bound by reference
        # and last dataname would be used
        lapply(
          self$datanames(),
          function(dataname) {
            fdataset <- private$get_filtered_dataset(dataname)
            fdataset$srv_add(id = dataname)
          }
        )
        logger::log_trace("FilteredData$srv_filter_panel initialized")
        NULL
      })
    },

    #' Creates the UI 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 module id
    ui_overview = function(id) {
      ns <- NS(id)
      div(
        id = id, # not used, can be used to customize CSS behavior
        class = "well",
        tags$div(
          class = "row",
          tags$div(
            class = "col-sm-9",
            tags$label("Active Filter Summary", class = "text-primary mb-4")
          ),
          tags$div(
            class = "col-sm-3",
            actionLink(
              ns("minimise_filter_overview"),
              label = NULL,
              icon = icon("angle-down", lib = "font-awesome"),
              title = "Minimise panel",
              class = "remove pull-right"
            )
          )
        ),
        div(
          id = ns("filters_overview_contents"),
          div(
            class = "teal_active_summary_filter_panel",
            tableOutput(ns("table"))
          )
        )
      )
    },

    #' Server function to display the number of records in the filtered and unfiltered
    #' data
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param active_datanames (`reactive`)\cr
    #'   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 `moduleServer` function which returns `NULL`
    srv_overview = function(id, active_datanames = self$datanames) {
      checkmate::assert_class(active_datanames, "reactive")
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilteredData$srv_filter_overview initializing")

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

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

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

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


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

            body_html <- apply(
              datasets_df,
              1,
              function(x) {
                tags$tr(
                  tagList(
                    lapply(x, tags$td)
                  )
                )
              }
            )

            header_html <- tags$tr(
              tagList(
                lapply(colnames(datasets_df), tags$td)
              )
            )

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

    # deprecated - to remove after release --------------------------------------

    #' @description
    #' Method is deprecated. Provide resolved `active_datanames` to `srv_filter_panel`
    #'
    #' @param datanames `character vector` `datanames` to pick
    #'
    #' @return the intersection of `self$datanames()` and `datanames`
    #'
    handle_active_datanames = function(datanames) {
      stop("Deprecated with teal.slice 0.4.0")
    },

    #' @description
    #' Method is deprecated. Please extract column labels directly from the data.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @param variables (`character`) variables to get labels for;
    #'   if `NULL`, for all variables in data
    #'
    get_varlabels = function(dataname, variables = NULL) {
      stop("Deprecated with 0.4.0 - please extract column labels directly from the data.")
    },

    #' @description
    #' Method is deprecated, Please extract variable names directly from the data instead
    #'
    #' @param dataname (`character`) the name of the dataset
    #'
    get_varnames = function(dataname) {
      stop("Deprecated with 0.4.0 - please extract varniable names directly from the data")
    },

    #' @description
    #' Method is deprecated, please use `self$datanames()` instead
    #'
    #' @param dataname (`character` vector) names of the dataset
    #'
    get_filterable_datanames = function() {
      stop("Deprecated with 0.4.0 - please use self$datanames() instead")
    },

    #' @description
    #' Method is deprecated, please use `self$get_filter_state()` and retain `attr(, "filterable_varnames")` instead.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #'
    get_filterable_varnames = function(dataname) {
      stop("Deprecated with teal.slice 0.4.0 - see help(teal_slices) and description of include_varnames argument.")
    },

    #' @description
    #' Method is deprecated, please use `self$set_filter_state` and [teal_slices()] with `include_varnames` instead.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @param varnames (`character` or `NULL`)
    #'   variables which users can choose to filter the data;
    #'   see `self$get_filterable_varnames` for more details
    #'
    #'
    set_filterable_varnames = function(dataname, varnames) {
      stop("Deprecated with teal.slice 0.4.0 - see help(teal_slices) and description of include_varnames argument.")
    },

    #' @description
    #' Method is deprecated, please use `format.teal_slices` on object returned from `self$get_filter_state()`
    #'
    get_formatted_filter_state = function() {
      stop("Deprecated with teal.slice 0.4.0 - get_filter_state returns teal_slice which has dedicated format method")
    },

    #' @description
    #' Deprecated - please use `clear_filter_states` method.
    #'
    #' @param datanames (`character`)
    #'
    #' @return `NULL` invisibly
    #'
    remove_all_filter_states = function(datanames) {
      warning("FilteredData$remove_all_filter_states is deprecated, please use FilteredData$clear_filter_states.")
      self$clear_filter_states(dataname)
    }
  ),

  ## __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,

    # whether the datasets had a reproducibility check
    .check = FALSE,

    # preprocessing code used to generate the unfiltered datasets as a string
    code = NULL,

    # `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 JoinKeys object (see teal.data)
    join_keys = NULL,

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

    # private methods ----

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

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

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

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

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

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

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

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

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

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

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

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

        observeEvent(private$available_teal_slices(), ignoreNULL = FALSE, {
          if (length(private$available_teal_slices())) {
            shinyjs::show("available_menu")
          } else {
            shinyjs::hide("available_menu")
          }
        })
      })
    }
  )
)

# MAEFilteredDataset ------
#' @keywords internal
#' @title `MAEFilteredDataset` R6 class
MAEFilteredDataset <- R6::R6Class( # nolint
  classname = "MAEFilteredDataset",
  inherit = FilteredDataset,

  # public methods ----
  public = list(
    #' @description
    #' Initialize `MAEFilteredDataset` object
    #'
    #' @param dataset (`MulitiAssayExperiment`)\cr
    #'  a single `MultiAssayExperiment` for which to define a subset
    #' @param dataname (`character`)\cr
    #'  a given name for the dataset it may not contain spaces
    #' @param keys optional, (`character`)\cr
    #'   vector with primary keys
    #' @param label (`character`)\cr
    #'   label to describe the dataset
    #' @param metadata (named `list` or `NULL`) \cr
    #'   field containing metadata about the dataset;
    #'   each element of the list must be atomic and length one
    #'
    initialize = function(dataset, dataname, keys = character(0), label = character(0), metadata = NULL) {
      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, metadata)
      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 (`named list`)\cr
    #'  names of the list should correspond to the names of the initialized `FilterStates`
    #'  kept in `private$filter_states`. For this object they are `"subjects"` and
    #'  names of the experiments. Values of initial state should be relevant
    #'  to the referred column.
    #'
    #' @examples
    #' utils::data(miniACC, package = "MultiAssayExperiment")
    #' dataset <- teal.slice:::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)
    #' shiny::isolate(dataset$get_filter_state())
    #'
    #' @return `NULL` invisibly
    #'
    set_filter_state = function(state) {
      shiny::isolate({
        logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(x) {
          checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname")
        })

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

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

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

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

        invisible(NULL)
      })
    },

    #' @description
    #' Remove one or more `FilterState` of a `MAEFilteredDataset`
    #'
    #' @param state (`teal_slices`)\cr
    #'   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")

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

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


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

      invisible(NULL)
    },

    #' @description
    #' UI module to add filter variable for this dataset
    #'
    #' UI module to add filter variable for this dataset
    #' @param id (`character(1)`)\cr
    #'  identifier of the element - preferably containing dataset name
    #'
    #' @return function - shiny UI module
    #'
    ui_add = function(id) {
      ns <- NS(id)
      data <- self$get_dataset()
      experiment_names <- names(data)

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

    #' @description
    #' Get filter overview rows of a dataset
    #' @return (`matrix`) matrix of observations and subjects
    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)
    }
  )
)

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

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `FilterState` object
    #'
    #' @param x (`Date`)\cr
    #'   values of the variable used in filter
    #' @param x_reactive (`reactive`)\cr
    #'   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`)\cr
    #'   object created using [teal_slice()]. `teal_slice` is stored
    #'   in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`
    #'   returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`
    #'   is a `reactiveValues` which means that changes in particular object are automatically
    #'   reflected in all places which refer to the same `teal_slice`.
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by `dataname`. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #' @param ... additional arguments to be saved as a list in `private$extras` field
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          slice,
                          extract_type = character(0)) {
      shiny::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`)
    #'
    get_call = function(dataname) {
      if (isFALSE(private$is_any_filtered())) {
        return(NULL)
      }
      choices <- as.character(private$get_selected())
      varname <- private$get_varname_prefixed(dataname)
      filter_call <-
        call(
          "&",
          call(">=", varname, call("as.Date", choices[1L])),
          call("<=", varname, call("as.Date", choices[2L]))
        )
      private$add_keep_na_call(filter_call, varname)
    }
  ),

  # private methods ----

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

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

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

      values
    },

    # shiny modules ----

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

    # @description
    # Server module
    # @param id (`character(1)`)\cr
    #   an ID string that corresponds with the ID used to call the module's UI function.
    # @return `moduleServer` function which returns `NULL`
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }")

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

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

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

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


          private$keep_na_srv("keep_na")

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

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

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

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

          logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
          NULL
        }
      )
    },

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

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

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

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

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

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

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

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

      div(
        row_input,
        col_input
      )
    },

    #' @description
    #' Shiny server module to add filter variable
    #'
    #' Module controls available choices to select as a filter variable.
    #' Selected filter variable is being removed from available choices.
    #' Removed filter variable gets back to available choices.
    #' This module unlike other `FilterStates` classes manages two
    #' sets of filter variables - one for `colData` and another for
    #' `rowData`.
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @return `moduleServer` function which returns `NULL`
    srv_add = function(id) {
      data <- private$data
      data_reactive <- private$data_reactive
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("SEFilterState$srv_add initializing, dataname: { private$dataname }")

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

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

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

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

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

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

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

          observeEvent(
            avail_row_data_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_trace(paste(
                "SEFilterStates$srv_add@1 updating available row data choices,",
                "dataname: { private$dataname }"
              ))
              if (is.null(avail_row_data_choices())) {
                shinyjs::hide("row_to_add")
              } else {
                shinyjs::show("row_to_add")
              }
              teal.widgets::updateOptionalSelectInput(
                session,
                "row_to_add",
                choices = avail_row_data_choices()
              )
              logger::log_trace(paste(
                "SEFilterStates$srv_add@1 updated available row data choices,",
                "dataname: { private$dataname }"
              ))
            }
          )

          observeEvent(
            avail_col_data_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_trace(paste(
                "SEFilterStates$srv_add@2 updating available col data choices,",
                "dataname: { private$dataname }"
              ))
              if (is.null(avail_col_data_choices())) {
                shinyjs::hide("col_to_add")
              } else {
                shinyjs::show("col_to_add")
              }
              teal.widgets::updateOptionalSelectInput(
                session,
                "col_to_add",
                choices = avail_col_data_choices()
              )
              logger::log_trace(paste(
                "SEFilterStates$srv_add@2 updated available col data choices,",
                "dataname: { private$dataname }"
              ))
            }
          )

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

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


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

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

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

#' Initializes `FilterState`
#'
#' Initializes `FilterState` depending on a variable class.\cr
#' @param x (`vector`)\cr
#'   values of the variable used in filter
#' @param x_reactive (`reactive`)\cr
#'   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`)\cr
#'   object created using [teal_slice()].
#' @param extract_type (`character(0)`, `character(1)`)\cr
#'   specifying whether condition calls should be prefixed by `dataname`. Possible values:
#' \itemize{
#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
#' }
#' @param ... additional arguments to be saved as a list in `private$extras` field
#'
#' @keywords internal
#'
#' @examples
#' filter_state <- teal.slice:::init_filter_state(
#'   x = c(1:10, NA, Inf),
#'   x_reactive = reactive(c(1:10, NA, Inf)),
#'   slice = teal_slice(
#'     varname = "x",
#'     dataname = "dataname"
#'   ),
#'   extract_type = "matrix"
#' )
#'
#' shiny::isolate(filter_state$get_call())
#' app <- shinyApp(
#'   ui = fluidPage(
#'     filter_state$ui(id = "app"),
#'     verbatimTextOutput("call")
#'   ),
#'   server = function(input, output, session) {
#'     filter_state$server("app")
#'
#'     output$call <- renderText(
#'       deparse1(filter_state$get_call(), collapse = "\n")
#'     )
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
#' @return `FilterState` object
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
#'
#' Initialize a `FilterStateExpr` object
#' @param slice (`teal_slice_expr`)\cr
#'   object created using [teal_slice()]. `teal_slice` is stored
#'   in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`
#'   returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`
#'   is a `reactiveValues` which means that changes in particular object are automatically
#'   reflected in all places which refer to the same `teal_slice`.
#'
#' @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
#' teal.slice:::fetch_bs_color("primary")
#' teal.slice:::fetch_bs_color("danger", 0.35)
#' teal.slice:::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
  ## TODO this is not ideal
  sass_file <- bslib::bs_theme()[["layers"]][[2]][["defaults"]][[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)
}

#' Managing `FilteredData` states
#'
#' @description `r lifecycle::badge("experimental")`
#' Set, get and remove filter states of `FilteredData` object
#'
#' @name filter_state_api
#'
#' @param datasets (`FilteredData`)\cr
#'   object to store filter state and filtered datasets, shared across modules\cr
#'   see [`FilteredData`] for details
#'
#' @param filter (`teal_slices`)\cr
#'   specify filters in place on app start-up
#'
#' @param force (`logical(1)`)\cr
#'   include locked 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
#' utils::data(miniACC, package = "MultiAssayExperiment")
#'
#' datasets <- init_filtered_data(
#'   x = list(
#'     iris = list(dataset = iris),
#'     mae = list(dataset = miniACC)
#'   )
#' )
#' 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 = "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 = "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 = "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(
    checkmate::check_class(filter, "teal_slices"),
    checkmate::check_list(filter, min.len = 0, null.ok = TRUE)
  )
  if (!is.teal_slices(filter)) {
    filter <- list_to_teal_slices(filter)
  }

  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 (shiny::isRunning()) {
    datasets$get_filter_state()
  } else {
    shiny::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(
    checkmate::check_class(filter, "teal_slices"),
    checkmate::check_list(filter, min.len = 0, null.ok = TRUE)
  )

  datasets$remove_filter_state(filter)
  invisible(NULL)
}

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

#' Gets filter expression for multiple `datanames` taking into account its order.
#'
#' @description `r lifecycle::badge("stable")`
#' To be used in show R code button.
#'
#' @param datasets (`FilteredData`)
#' @param datanames (`character`) vector of dataset names
#'
#' @export
#'
#' @return (`expression`)
get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
  checkmate::assert_character(datanames, min.len = 1, any.missing = FALSE)
  stopifnot(
    is(datasets, "FilteredData"),
    all(datanames %in% datasets$datanames())
  )

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

# DefaultFilteredDataset ------
#' @title The `DefaultFilteredDataset` R6 class
#' @keywords internal
#' @examples
#' library(shiny)
#' ds <- teal.slice:::DefaultFilteredDataset$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())
DefaultFilteredDataset <- R6::R6Class( # nolint
  classname = "DefaultFilteredDataset",
  inherit = FilteredDataset,
  public = list(

    #' @description
    #' Initializes this `DefaultFilteredDataset` object
    #'
    #' @param dataset (`data.frame`)\cr
    #'  single data.frame for which filters are rendered
    #' @param dataname (`character`)\cr
    #'  A given name for the dataset it may not contain spaces
    #' @param keys optional, (`character`)\cr
    #'   Vector with primary keys
    #' @param parent_name (`character(1)`)\cr
    #'   Name of the parent dataset
    #' @param parent (`reactive`)\cr
    #'   object returned by this reactive is a filtered `data.frame` from other `FilteredDataset`
    #'   named `parent_name`. Consequence of passing `parent` is a `reactive` link which causes
    #'   causing re-filtering of this `dataset` based on the changes in `parent`.
    #' @param join_keys (`character`)\cr
    #'   Name of the columns in this dataset to join with `parent`
    #'   dataset. If the column names are different if both datasets
    #'   then the names of the vector define the `parent` columns.
    #'
    #' @param label (`character`)\cr
    #'   Label to describe the dataset
    #' @param metadata (named `list` or `NULL`) \cr
    #'   Field containing metadata about the dataset. Each element of the list
    #'   should be atomic and length one.
    initialize = function(dataset,
                          dataname,
                          keys = character(0),
                          parent_name = character(0),
                          parent = NULL,
                          join_keys = character(0),
                          label = character(0),
                          metadata = NULL) {
      checkmate::assert_data_frame(dataset)
      super$initialize(dataset, dataname, keys, label, metadata)

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

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

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

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

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

      invisible(self)
    },

    #' @description
    #' Gets the filter expression
    #'
    #' This functions 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.
    #' This class contains single `FilterStates`
    #' which contains single `state_list` and all `FilterState` objects
    #' applies to one argument (`...`) in `dplyr::filter` call.
    #'
    #' @param sid (`character`)\cr
    #'  when specified then method returns code containing filter conditions of
    #'  `FilterState` objects which `"sid"` attribute is different than this `sid` argument.
    #'
    #' @return filter `call` or `list` of filter calls
    get_call = function(sid = "") {
      logger::log_trace("FilteredDatasetDefault$get_call initializing for dataname: { private$dataname }")
      filter_call <- super$get_call(sid)
      dataname <- private$dataname
      parent_dataname <- private$parent_name

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

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

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

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

        filter_call <- c(filter_call, merge_call)
      }
      logger::log_trace("FilteredDatasetDefault$get_call initializing for dataname: { private$dataname }")
      filter_call
    },

    #' @description
    #' Set filter state
    #'
    #' @param state (`teal_slice`) object
    #'
    #' @examples
    #' dataset <- teal.slice:::DefaultFilteredDataset$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)
    #' shiny::isolate(dataset$get_filter_state())
    #'
    #' @return `NULL` invisibly
    #'
    set_filter_state = function(state) {
      shiny::isolate({
        logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(slice) {
          checkmate::assert_true(slice$dataname == private$dataname)
        })
        private$get_filter_states()[[1L]]$set_filter_state(state = state)
        invisible(NULL)
      })
    },

    #' @description
    #' Remove one or more `FilterState` form a `FilteredDataset`
    #'
    #' @param state (`teal_slices`)\cr
    #'   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")

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

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

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

      invisible(NULL)
    },

    #' @description
    #' UI module to add filter variable for this dataset
    #'
    #' UI module to add filter variable for this dataset
    #' @param id (`character(1)`)\cr
    #'  identifier of the element - preferably containing dataset name
    #'
    #' @return function - shiny UI module
    ui_add = function(id) {
      ns <- NS(id)
      tagList(
        tags$label("Add", tags$code(self$get_dataname()), "filter"),
        private$get_filter_states()[["filter"]]$ui_add(id = ns("filter"))
      )
    },

    #' @description
    #' Get number of observations based on given keys
    #' The output shows the comparison between `filtered_dataset`
    #' function parameter and the dataset inside self
    #' @return `list` containing character `#filtered/#not_filtered`
    get_filter_overview = function() {
      logger::log_trace("FilteredDataset$srv_filter_overview initialized")
      # Gets filter overview subjects number and returns a list
      # of the number of subjects of filtered/non-filtered datasets
      subject_keys <- if (length(private$parent_name) > 0) {
        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 = list(
    parent_name = character(0),
    join_keys = character(0)
  )
)

# FilteredDataset abstract --------
#' @title `FilterStates` 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 (`data.frame` or `MultiAssayExperiment`)\cr
    #'  single dataset for which filters are rendered
    #' @param dataname (`character(1)`)\cr
    #'  A given name for the dataset it may not contain spaces
    #' @param keys optional, (`character`)\cr
    #'   Vector with primary keys
    #' @param label (`character(1)`)\cr
    #'   Label to describe the dataset
    #' @param metadata (named `list` or `NULL`) \cr
    #'   Field containing metadata about the dataset. Each element of the list
    #'   should be atomic and length one.
    initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label"), metadata = NULL) {
      logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")

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

      logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
      private$dataset <- dataset
      private$dataname <- dataname
      private$keys <- keys
      private$label <- if (is.null(label)) character(0) else label
      private$metadata <- metadata

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

      private$data_filtered <- reactive(private$data_filtered_fun())
      logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
      invisible(self)
    },

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

    #' @description
    #' Removes all active filter items applied to this dataset
    #' @param force (`logical(1)`)\cr
    #'   include locked filter states
    #'
    #' @return NULL
    clear_filter_states = function(force = FALSE) {
      logger::log_trace("Removing filters from FilteredDataset: { deparse1(self$get_dataname()) }")
      lapply(
        private$get_filter_states(),
        function(filter_states) filter_states$clear_filter_states(force)
      )
      logger::log_trace("Removed filters from FilteredDataset: { deparse1(self$get_dataname()) }")
      NULL
    },

    # managing filter states -----

    # getters ----
    #' @description
    #' Gets a filter expression
    #'
    #' This functions 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`)\cr
    #'  when specified then method returns code containing filter conditions of
    #'  `FilterState` objects which `"sid"` attribute is different than this `sid` argument.
    #'
    #' @return filter `call` or `list` of filter calls
    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 active `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_slice`) object
    #'
    #' @return `NULL` invisibly
    #'
    set_filter_state = function(state) {
      stop("set_filter_state is an abstract class method.")
    },

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

    #' @description
    #' Gets the name of the dataset
    #'
    #' @return `character(1)` as a name of this dataset
    get_dataname = function() {
      private$dataname
    },

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

    #' @description
    #' Gets the metadata for the dataset in this `FilteredDataset`
    #' @return named `list` or `NULL`
    get_metadata = function() {
      private$metadata
    },

    #' @description
    #' Get filter overview rows of a dataset
    #' The output shows the comparison between `filtered_dataset`
    #' function parameter and the dataset inside self
    #' @param filtered_dataset comparison object, of the same class
    #' as `self$get_dataset()`, if `NULL` then `self$get_dataset()`
    #' is used.
    #' @return (`data.frame`) matrix of observations and subjects
    get_filter_overview = function() {
      dataset <- self$get_dataset()
      data_filtered <- self$get_dataset(TRUE)
      data.frame(
        dataname = private$dataname,
        obs = nrow(dataset),
        obs_filtered = nrow(data_filtered)
      )
    },

    #' @description
    #' Gets the keys for the dataset of this `FilteredDataset`
    #' @return (`character`) the keys of dataset
    get_keys = function() {
      private$keys
    },

    #' @description
    #' Gets the dataset label
    #' @return (`character`) the dataset label
    get_dataset_label = function() {
      private$label
    },

    # modules ------
    #' @description
    #' UI module for dataset active filters
    #'
    #' UI module containing dataset active filters along with
    #' title and remove button.
    #' @param id (`character(1)`)\cr
    #'  identifier of the element - preferably containing dataset name
    #'
    #' @return function - shiny UI module
    ui_active = function(id) {
      dataname <- self$get_dataname()
      checkmate::assert_string(dataname)

      ns <- NS(id)
      if_multiple_filter_states <- length(private$get_filter_states()) > 1
      span(
        id = id,
        include_css_files("filter-panel"),
        div(
          id = ns("whole_ui"), # to hide it entirely
          fluidRow(
            column(
              width = 8,
              tags$span(dataname, class = "filter_panel_dataname")
            ),
            column(
              width = 4,
              tagList(
                actionLink(
                  ns("remove_filters"),
                  label = "",
                  icon = icon("circle-xmark", lib = "font-awesome"),
                  class = "remove pull-right"
                ),
                actionLink(
                  ns("collapse"),
                  label = "",
                  icon = icon("angle-down", lib = "font-awesome"),
                  class = "remove pull-right"
                )
              )
            )
          ),
          shinyjs::hidden(
            div(
              id = ns("filter_count_ui"),
              tagList(
                textOutput(ns("filter_count")),
                br()
              )
            )
          ),
          div(
            # id needed to insert and remove UI to filter single variable as needed
            # it is currently also used by the above module to entirely hide this panel
            id = ns("filters"),
            class = "parent-hideable-list-group",
            tagList(
              lapply(
                names(private$get_filter_states()),
                function(x) {
                  tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x)))
                }
              )
            )
          )
        )
      )
    },

    #' @description
    #' Server module for a dataset active filters
    #'
    #' Server module managing a  active filters.
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @return `moduleServer` function which returns `NULL`
    srv_active = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          dataname <- self$get_dataname()
          logger::log_trace("FilteredDataset$srv_active initializing, dataname: { dataname }")
          checkmate::assert_string(dataname)
          output$filter_count <- renderText(
            sprintf(
              "%d filter%s applied",
              self$get_filter_count(),
              if (self$get_filter_count() != 1) "s" else ""
            )
          )

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

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

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

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

          logger::log_trace("FilteredDataset$initialized, dataname: { dataname }")

          NULL
        }
      )
    },

    #' @description
    #' UI module to add filter variable for this dataset
    #'
    #' UI module to add filter variable for this dataset
    #' @param id (`character(1)`)\cr
    #'  identifier of the element - preferably containing dataset name
    #'
    #' @return function - shiny UI module
    ui_add = function(id) {
      stop("Pure virtual method")
    },

    #' @description
    #' Server module to add filter variable for this dataset
    #'
    #' 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)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #'
    #' @return `moduleServer` function which returns `NULL`
    #'
    srv_add = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("MAEFilteredDataset$srv_add initializing, dataname: { deparse1(self$get_dataname()) }")
          elems <- private$get_filter_states()
          elem_names <- names(private$get_filter_states())
          lapply(
            elem_names,
            function(elem_name) elems[[elem_name]]$srv_add(elem_name)
          )
          logger::log_trace("MAEFilteredDataset$srv_add initialized, dataname: { deparse1(self$get_dataname()) }")
          NULL
        }
      )
    }
  ),
  ## __Private Fields ====
  private = list(
    dataset = NULL, # data.frame or MultiAssayExperiment
    data_filtered = NULL,
    data_filtered_fun = NULL, # function
    filter_states = list(),
    dataname = character(0),
    keys = character(0),
    label = character(0),
    metadata = NULL,

    # 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 the active `FilterStates` objects.
    # @param id (`character(1)`, `character(0)`)\cr
    #   the id of the `private$filter_states` list element where `FilterStates` is kept.
    # @return `FilterStates` or `list` of `FilterStates` objects.
    get_filter_states = function() {
      private$filter_states
    }
  )
)

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

  # public methods ----
  public = list(

    #' @description
    #' Initialize a `FilterState` object for range selection
    #' @param x (`numeric`)\cr
    #'   values of the variable used in filter
    #' @param x_reactive (`reactive`)\cr
    #'   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`)\cr
    #'   object created using [teal_slice()]. `teal_slice` is stored
    #'   in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`
    #'   returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`
    #'   is a `reactiveValues` which means that changes in particular object are automatically
    #'   reflected in all places which refer to the same `teal_slice`.
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by `dataname`. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #' @param ... additional arguments to be saved as a list in `private$extras` field
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          extract_type = character(0),
                          slice) {
      shiny::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 = 2,
              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())
          list(
            x = finite_values,
            bingroup = 1,
            color = I(fetch_bs_color("primary"))
          )
        })
        invisible(self)
      })
    },

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

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

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

    # private methods ----

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

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

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

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

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

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

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

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

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

    # shiny modules ----

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

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

    # @description
    # Server module
    # @param id (`character(1)`)\cr
    #   an ID string that corresponds with the ID used to call the module's UI function.
    # return `moduleServer` function which returns `NULL`
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }")

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

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

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

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

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

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

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

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


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

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

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

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

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

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

          logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
          NULL
        }
      )
    },

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

    # @description
    # module displaying input to keep or remove Inf in the FilterState call
    # @param id `shiny` id parameter
    #  renders checkbox input only when variable from which FilterState has
    #  been created has some Inf values.
    keep_inf_ui = function(id) {
      ns <- NS(id)

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

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

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

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

        invisible(NULL)
      })
    }
  )
)

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

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

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

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

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

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

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

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

  return(choices)
}

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

  # public methods ----
  public = list(

    #' @description
    #' Initialize a `FilterState` object
    #'
    #' @param x (`logical`)\cr
    #'   values of the variable used in filter
    #' @param x_reactive (`reactive`)\cr
    #'   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`)\cr
    #'   object created using [teal_slice()]. `teal_slice` is stored
    #'   in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`
    #'   returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`
    #'   is a `reactiveValues` which means that changes in particular object are automatically
    #'   reflected in all places which refer to the same `teal_slice`.
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by `dataname`. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #' @param ... additional arguments to be saved as a list in `private$extras` field
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          extract_type = character(0),
                          slice) {
      shiny::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 <- shiny::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)`)\cr
    #  id of shiny element
    ui_inputs = function(id) {
      ns <- NS(id)
      shiny::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 = shiny::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 = shiny::isolate(as.character(private$get_selected())),
            choiceNames = labels,
            choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
            width = "100%"
          )
        }
        div(
          div(
            class = "choices_state",
            uiOutput(ns("trigger_visible"), inline = TRUE),
            ui_input
          ),
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

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

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

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

          private$observers$seleted_api <- observeEvent(
            ignoreNULL = !private$is_multiple(),
            ignoreInit = TRUE,
            eventExpr = private$get_selected(),
            handlerExpr = {
              if (!setequal(private$get_selected(), input$selection)) {
                logger::log_trace("LogicalFilterState$server@1 state changed, id: { private$get_id() }")
                if (private$is_multiple()) {
                  updateCheckboxGroupInput(
                    inputId = "selection",
                    selected = private$get_selected()
                  )
                } else {
                  updateRadioButtons(
                    inputId = "selection",
                    selected = private$get_selected()
                  )
                }
              }
            }
          )

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

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

          private$keep_na_srv("keep_na")

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

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

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

          logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
          NULL
        }
      )
    },

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

#' @rdname DatetimeFilterState
#' @title `FilterState` object for `POSIXct` variable
#' @description  Manages choosing a range of date-times
#' @docType class
#' @keywords internal
#'
#'
#' @examples
#' filter_state <- teal.slice:::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)
#' )
#' shiny::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
#'   )
#' )
#' shiny::isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shiny)
#' 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 <- teal.slice:::DatetimeFilterState$new(
#'   x = data_datetime,
#'   slice = teal_slice(
#'     varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE
#'   )
#' )
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   teal.slice:::include_css_files(pattern = "filter-panel"),
#'   teal.slice:::include_js_files(pattern = "count-bar-labels"),
#'   column(4, div(
#'     h4("DatetimeFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, div(
#'     id = "outputs", # div id is needed for toggling the element
#'     h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
#'     textOutput("condition_datetime"), br(),
#'     h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_datetime"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_datetime"), br()
#'   )),
#'   column(4, div(
#'     h4("Programmatic filter control"),
#'     actionButton("button1_datetime", "set drop NA", width = "100%"), br(),
#'     actionButton("button2_datetime", "set keep NA", width = "100%"), br(),
#'     actionButton("button3_datetime", "set a range", width = "100%"), br(),
#'     actionButton("button4_datetime", "set full range", width = "100%"), br(),
#'     actionButton("button0_datetime", "set initial state", width = "100%"), br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_datetime <- renderPrint(fs$get_call())
#'   output$formatted_datetime <- renderText(fs$format())
#'   output$unformatted_datetime <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_datetime,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#'   )
#'   observeEvent(
#'     input$button2_datetime,
#'     fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#'   )
#'   observeEvent(
#'     input$button3_datetime,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)])
#'     )
#'   )
#'   observeEvent(
#'     input$button4_datetime,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "x", selected = datetimes)
#'     )
#'   )
#'   observeEvent(
#'     input$button0_datetime,
#'     fs$set_state(
#'       teal_slice(
#'         dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE
#'       )
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
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`)\cr
    #'   values of the variable used in filter
    #' @param x_reactive (`reactive`)\cr
    #'   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`)\cr
    #'   object created using [teal_slice()]. `teal_slice` is stored
    #'   in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`
    #'   returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`
    #'   is a `reactiveValues` which means that changes in particular object are automatically
    #'   reflected in all places which refer to the same `teal_slice`.
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by `dataname`. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #' @param ... additional arguments to be saved as a list in `private$extras` field
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          extract_type = character(0),
                          slice) {
      shiny::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)`)\cr
    #  id of shiny element
    ui_inputs = function(id) {
      ns <- NS(id)

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

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

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

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


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

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

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

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

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

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

          private$keep_na_srv("keep_na")

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

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

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

          logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
          NULL
        }
      )
    },

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

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

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `InteractiveFilterState` object
    #'
    #' @param x (`vector`)\cr
    #'   values of the variable used in filter
    #' @param x_reactive (`reactive`)\cr
    #'   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`)\cr
    #'   object created using [teal_slice()]. `teal_slice` is stored
    #'   in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`
    #'   returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`
    #'   is a `reactiveValues` which means that changes in particular object are automatically
    #'   reflected in all places which refer to the same `teal_slice`.
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by `dataname`. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #' @param ... additional arguments to be saved as a list in `private$extras` field
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          slice,
                          extract_type = character(0)) {
      shiny::isolate({
        checkmate::assert(
          is.character(x),
          is.factor(x),
          length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
          combine = "or"
        )

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

        super$initialize(
          x = x_factor,
          x_reactive = x_reactive,
          slice = slice,
          extract_type = extract_type
        )
        private$set_choices(slice$choices)
        if (is.null(slice$selected) && slice$multiple) {
          slice$selected <- private$get_choices()
        } else if (is.null(slice$selected)) {
          slice$selected <- private$get_choices()[1]
        } else if (length(slice$selected) > 1 && !slice$multiple) {
          warning(
            "ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ",
            "Only the first value will be used."
          )
          slice$selected <- slice$selected[1]
        }
        private$set_selected(slice$selected)
        private$data_class <- class(x)[1L]
        if (inherits(x, "POSIXt")) {
          private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))
        }

        private$set_choices_counts(unname(table(x_factor)))
      })
      invisible(self)
    },

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For this class returned call looks like
    #' `<varname> %in%  c(<values selected>)` with
    #' optional `is.na(<varname>)`.
    #' @param dataname name of data set; defaults to `private$get_dataname()`
    #' @return (`call`) or `NULL`
    #'
    get_call = function(dataname) {
      if (isFALSE(private$is_any_filtered())) {
        return(NULL)
      }
      if (missing(dataname)) dataname <- private$get_dataname()
      varname <- private$get_varname_prefixed(dataname)
      selected <- private$get_selected()
      if (length(selected) == 0) {
        choices <- private$get_choices()
        fun_compare <- if (length(choices) == 1L) "==" else "%in%"
        filter_call <- call("!", call(fun_compare, varname, make_c_call(as.character(choices))))
      } else {
        if (setequal(na.omit(private$x), selected)) {
          filter_call <- NULL
        } else {
          fun_compare <- if (length(selected) == 1L) "==" else "%in%"

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

          filter_call <-
            if (inherits(selected, "Date")) {
              call(fun_compare, varname, call("as.Date", make_c_call(as.character(selected))))
            } else if (inherits(selected, c("POSIXct", "POSIXlt"))) {
              class <- class(selected)[1L]
              date_fun <- as.name(
                switch(class,
                  "POSIXct" = "as.POSIXct",
                  "POSIXlt" = "as.POSIXlt"
                )
              )
              call(
                fun_compare,
                varname,
                as.call(list(date_fun, make_c_call(as.character(selected)), tz = private$tzone))
              )
            } else {
              # This handles numerics, characters, and factors.
              call(fun_compare, varname, make_c_call(selected))
            }
        }
      }
      private$add_keep_na_call(filter_call, varname)
    }
  ),

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

    # private methods ----

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

    # shiny modules ----

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

      # we need to isolate UI to not rettrigger renderUI
      shiny::isolate({
        countsmax <- private$choices_counts
        countsnow <- if (!is.null(private$x_reactive())) {
          unname(table(factor(private$x_reactive(), levels = private$get_choices())))
        } else {
          NULL
        }

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

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

    # @description
    # Server module
    # @param id (`character(1)`)\cr
    #   an ID string that corresponds with the ID used to call the module's UI function.
    # @return `moduleServer` function which returns `NULL`
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }")

          # 1. renderUI is used here as an observer which triggers only if output is visible
          #  and if the reactive changes - reactive triggers only if the output is visible.
          # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)
          non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))
          output$trigger_visible <- renderUI({
            logger::log_trace("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")

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

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

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

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

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

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


          private$keep_na_srv("keep_na")

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

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

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

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

          logger::log_trace("ChoicesFilterState$server_inputs_fixed initialized, id: { private$get_id() }")
          NULL
        }
      )
    },

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

#' @name FilterPanelAPI
#' @docType class
#'
#' @title Class to encapsulate the API of the filter panel of a teal app
#'
#' @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.
#'
#' @export
#'
#' @examples
#' library(teal.slice)
#' fd <- teal.slice::init_filtered_data(list(iris = list(dataset = 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())
#'
FilterPanelAPI <- R6::R6Class( # nolint
  "FilterPanelAPI",
  ## __Public Methods ====
  public = list(
    #' @description
    #' Initialize a `FilterPanelAPI` object
    #' @param datasets (`FilteredData`) object.
    #'
    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`)\cr
    #'   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`)\cr
    #'  `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
  )
)

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

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

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


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


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

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


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


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

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


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

  excludes <- lapply(x, attr, "exclude_varnames")
  names(excludes) <- NULL
  excludes <- unlist(excludes, recursive = FALSE)
  excludes <- excludes[!duplicated(names(excludes))]

  includes <- lapply(x, attr, "include_varnames")
  names(includes) <- NULL
  includes <- unlist(includes, recursive = FALSE)
  includes <- includes[!duplicated(names(includes))]

  count_types <- lapply(x, attr, "count_type")
  count_types <- unique(unlist(count_types))

  do.call(
    teal_slices,
    c(
      unique(unlist(x, recursive = FALSE)),
      list(
        include_varnames = if (length(includes)) includes,
        exclude_varnames = if (length(excludes)) excludes,
        count_type = count_types
      )
    )
  )
}


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

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

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

  jsonify(slices_list, trim_lines)
}


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


#' `setdiff` method for `teal_slices`
#'
#' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`.
#' @param x,y `teal_slices` objects
#' @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
  )
}


#' @rdname teal_slices
#' @export
#' @keywords internal
#'
list_to_teal_slices <- function(x) { # nolint
  checkmate::assert_list(x, names = "named")
  is_bottom <- function(x) {
    isTRUE(is.list(x) && any(names(x) %in% c("selected", "keep_na", "keep_inf"))) ||
      identical(x, list()) ||
      is.atomic(x)
  }
  make_args <- function(object, dataname, varname, experiment = NULL, arg = NULL) {
    args <- list(
      dataname = dataname,
      varname = varname
    )
    if (!is.null(experiment)) args$experiment <- experiment
    if (!is.null(arg)) args$arg <- arg
    if (is.list(object)) {
      args <- c(args, object)
    } else if (is.atomic(object)) {
      args$selected <- object
    }
    args
  }
  slices <- vector("list")

  for (dataname in names(x)) {
    item <- x[[dataname]]
    for (name_i in names(item)) {
      subitem <- item[[name_i]]
      if (is_bottom(subitem)) {
        args <- make_args(
          subitem,
          dataname = dataname,
          varname = name_i
        )
        slices <- c(slices, list(as.teal_slice(args)))
      } else {
        # MAE zone
        for (name_ii in names(subitem)) {
          subsubitem <- subitem[[name_ii]]
          if (is_bottom(subsubitem)) {
            args <- make_args(
              subsubitem,
              dataname = dataname,
              experiment = if (name_i != "subjects") name_i,
              varname = name_ii
            )
            slices <- c(slices, list(as.teal_slice(args)))
          } else {
            for (name_iii in names(subsubitem)) {
              subsubsubitem <- subsubitem[[name_iii]]
              if (is_bottom(subsubsubitem)) {
                args <- make_args(
                  subsubsubitem,
                  dataname = dataname,
                  experiment = name_i,
                  arg = name_ii,
                  varname = name_iii
                )
                slices <- c(slices, list(as.teal_slice(args)))
              }
            }
          }
        }
      }
    }
  }

  if (length(slices) == 0L && length(x) != 0L) {
    stop("conversion to filter_slices failed")
  }

  do.call(teal_slices, c(slices, list(include_varnames = attr(x, "filterable"))))
}

#' Get classes of selected columns from dataset
#'
#' @param data (`data.frame`) data to determine variable types from
#' @param columns (atomic vector of `character` or `NULL`) column names chosen from `data`.
#'   The value of `NULL` will be interpreted to mean all columns.
#'
#' @return (atomic vector of `character`) classes of `columns` from provided `data`
#' @keywords internal
#' @examples
#' teal.slice:::variable_types(
#'   data.frame(
#'     x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
#'     stringsAsFactors = FALSE
#'   ),
#'   "x"
#' )
#'
#' teal.slice:::variable_types(
#'   data.frame(
#'     x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
#'     stringsAsFactors = FALSE
#'   ),
#'   c("x", "z")
#' )
#'
#' teal.slice:::variable_types(
#'   data.frame(
#'     x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
#'     stringsAsFactors = FALSE
#'   )
#' )
variable_types <- function(data, columns = NULL) {
  UseMethod("variable_types")
}

#' @export
variable_types.default <- function(data, columns = NULL) {
  checkmate::assert_character(columns, null.ok = TRUE, any.missing = FALSE)

  res <- if (is.null(columns)) {
    vapply(
      data,
      function(x) class(x)[[1]],
      character(1),
      USE.NAMES = FALSE
    )
  } else if (checkmate::test_character(columns, any.missing = FALSE)) {
    stopifnot(all(columns %in% names(data) | vapply(columns, identical, logical(1L), "")))
    vapply(
      columns,
      function(x) ifelse(x == "", "", class(data[[x]])[[1]]),
      character(1),
      USE.NAMES = FALSE
    )
  } else {
    character(0)
  }

  return(res)
}

#' @export
variable_types.data.frame <- function(data, columns = NULL) { # nolint: object_name_linter.
  variable_types.default(data, columns)
}

#' @export
variable_types.DataTable <- function(data, columns = NULL) {
  variable_types.default(data, columns)
}

#' @export
variable_types.DFrame <- function(data, columns = NULL) {
  variable_types.default(data, columns)
}

#' @export
variable_types.matrix <- function(data, columns = NULL) {
  checkmate::assert_character(columns, null.ok = TRUE, any.missing = FALSE)

  res <- if (is.null(columns)) {
    apply(
      data,
      2,
      function(x) class(x)[1]
    )
  } else if (checkmate::test_character(columns, any.missing = FALSE)) {
    stopifnot(
      all(
        columns %in% colnames(data) |
          vapply(columns, identical, logical(1L), "")
      )
    )
    vapply(
      columns,
      function(x) ifelse(x == "", "", class(data[, x])[1]),
      character(1),
      USE.NAMES = FALSE
    )
  } else {
    character(0)
  }

  return(res)
}

#' Initialize `FilteredData`
#'
#' Initialize `FilteredData`
#' @param x (named `list` or `TealData`) In case of `TealData` see [teal.data::teal_data()].
#'  If the list is provided, it should contain `list`(s) containing following fields:
#' - `dataset` data object object supported by [`FilteredDataset`].
#' - `metatada` (optional) additional metadata attached to the `dataset`.
#' - `keys` (optional) primary keys.
#' - `datalabel` (optional) label describing the `dataset`.
#' - `parent` (optional) which `dataset` is a parent of this one.
#' @param join_keys (`JoinKeys`) see [teal.data::join_keys()].
#' @param code (`CodeClass`) see [`teal.data::CodeClass`].
#' @param check (`logical(1)`) whether data has been check against reproducibility.
#' @examples
#' library(shiny)
#' datasets <- teal.slice::init_filtered_data(
#'   x = list(
#'     iris = list(dataset = iris),
#'     mtcars = list(dataset = mtcars, metadata = list(type = "training"))
#'   )
#' )
#' @export
init_filtered_data <- function(x, join_keys, code, check) {
  UseMethod("init_filtered_data")
}

#' @keywords internal
#' @export
init_filtered_data.TealData <- function(x, # nolint
                                        join_keys = x$get_join_keys(),
                                        code = x$get_code_class(),
                                        check = x$get_check()) {
  data_objects <- lapply(
    x$get_datanames(),
    function(dataname) {
      dataset <- x$get_dataset(dataname)
      list(
        dataset = dataset$get_raw_data(),
        metadata = dataset$get_metadata(),
        label = dataset$get_dataset_label()
      )
    }
  )
  names(data_objects) <- x$get_datanames()

  init_filtered_data(
    x = data_objects,
    join_keys = join_keys,
    code = code,
    check = check
  )
}

#' @keywords internal
#' @export
init_filtered_data.default <- function(x, join_keys = teal.data::join_keys(), code = NULL, check = FALSE) { # nolint
  checkmate::assert_list(x, any.missing = FALSE, names = "unique")
  mapply(validate_dataset_args, x, names(x))
  checkmate::assert_class(code, "CodeClass", null.ok = TRUE)
  checkmate::assert_class(join_keys, "JoinKeys")
  checkmate::assert_flag(check)
  FilteredData$new(x, join_keys = join_keys, code = code, check = check)
}

#' Validate dataset arguments
#'
#' Validate dataset arguments
#' @param dataset_args (`list`)\cr
#'   containing the arguments except (`dataname`)
#'   needed by `init_filtered_dataset`
#' @param dataname (`character(1)`)\cr
#'   the name of the `dataset` to be added to this object
#' @keywords internal
#' @return (`NULL` or raises an error)
validate_dataset_args <- function(dataset_args, dataname) {
  check_simple_name(dataname)
  checkmate::assert_list(dataset_args, names = "unique")

  allowed_names <- c("dataset", "label", "metadata")

  checkmate::assert_subset(names(dataset_args), choices = allowed_names)
  checkmate::assert_multi_class(dataset_args[["dataset"]], classes = c("data.frame", "MultiAssayExperiment"))
  teal.data::validate_metadata(dataset_args[["metadata"]])
  checkmate::assert_character(dataset_args[["label"]], null.ok = TRUE, min.len = 0, max.len = 1)
}

#' Evaluate expression with meaningful message
#'
#' Method created for the `FilteredData` 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 invisible `NULL`.
#' @keywords internal
eval_expr_with_msg <- function(expr, env) {
  lapply(
    expr,
    function(x) {
      tryCatch(
        eval(x, envir = env),
        error = function(e) {
          stop(
            sprintf(
              "Call execution failed:\n - call:\n   %s\n - message:\n   %s ",
              deparse1(x, collapse = "\n"), e
            )
          )
        }
      )
      return(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 Invisible NULL.
#'
#' @name toggle_button
#'
#' @examples
#' library(shiny)
#'
#' ui <- fluidPage(
#'   shinyjs::useShinyjs(),
#'   actionButton("hide_content", label = "hide", icon = icon("xmark")),
#'   actionButton("show_content", label = "show", icon = icon("check")),
#'   actionButton("toggle_content", label = "toggle", icon = icon("angle-down")),
#'   br(),
#'   div(
#'     id = "content",
#'     verbatimTextOutput("printout")
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   observeEvent(input$hide_content,
#'     {
#'       shinyjs::hide("content")
#'       toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE)
#'     },
#'     ignoreInit = TRUE
#'   )
#'
#'   observeEvent(input$show_content,
#'     {
#'       shinyjs::show("content")
#'       toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE)
#'     },
#'     ignoreInit = TRUE
#'   )
#'
#'   observeEvent(input$toggle_content,
#'     {
#'       shinyjs::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)
#' }
#'
#' @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)
}

#' Topological graph sort
#'
#' Graph is a list which for each node contains a vector of child nodes
#' in the returned list, parents appear before their children.
#'
#' Implementation of `Kahn` algorithm with a modification to maintain the order of input elements.
#'
#' @param graph (named `list`) list with node vector elements
#' @keywords internal
#'
#' @examples
#' teal.slice:::topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
#' teal.slice:::topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
#' teal.slice:::topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
topological_sort <- function(graph) {
  # compute in-degrees
  in_degrees <- list()
  for (node in names(graph)) {
    in_degrees[[node]] <- 0
    for (to_edge in graph[[node]]) {
      in_degrees[[to_edge]] <- 0
    }
  }

  for (node in graph) {
    for (to_edge in node) {
      in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1
    }
  }

  # sort
  visited <- 0
  sorted <- list()
  zero_in <- list()
  for (node in names(in_degrees)) {
    if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node)
  }
  zero_in <- rev(zero_in)

  while (length(zero_in) != 0) {
    visited <- visited + 1
    sorted <- c(zero_in[[1]], sorted)
    for (edge_to in graph[[zero_in[[1]]]]) {
      in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1
      if (in_degrees[[edge_to]] == 0) {
        zero_in <- append(zero_in, edge_to, 1)
      }
    }
    zero_in[[1]] <- NULL
  }

  if (visited != length(in_degrees)) {
    stop(
      "Graph is not a directed acyclic graph. Cycles involving nodes: ",
      paste0(setdiff(names(in_degrees), sorted), collapse = " ")
    )
  } else {
    return(sorted)
  }
}

#' Combine calls by operator
#'
#' Combine list of calls by specific operator
#'
#' @param calls (`list` of calls)\cr
#'   list containing calls to be combined by `operator`;
#'   if empty, NULL is returned
#' @param operator (`character(1)`)\cr
#'   name/symbol of the operator passed as character string
#'
#' @return call or NULL, if `calls` is an empty list
#'
#' @examples
#' calls <- list(
#'   quote(SEX == "F"), # subsetting on factor
#'   quote(AGE >= 20 & AGE <= 50), # subsetting on range
#'   quote(!SURV) # subsetting on logical
#' )
#' teal.slice:::calls_combine_by(calls, "&")
#'
#' @return a combined `call`
#' @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)

  calls <- Filter(x = calls, f = Negate(is.null))

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

#' @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
    #'
    #' Initialize `MatrixFilterStates` object
    #'
    #' @param data (`matrix`)\cr
    #'   the R object which `subset` function is applied on.
    #' @param data_reactive (`function(sid)`)\cr
    #'   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)`)\cr
    #'   name of the data used in the expression
    #'   specified to the function argument attached to this `FilterStates`.
    #' @param datalabel (`NULL` or `character(1)`)\cr
    #'   text label value. Should be a name of experiment.
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL) {
      checkmate::assert_matrix(data)
      super$initialize(data, data_reactive, dataname, datalabel)
      private$set_filterable_varnames(include_varnames = colnames(private$data))
    }
  ),
  private = list(
    extract_type = "matrix"
  )
)

#' Ensure the ellipsis, ..., in method arguments are empty
#'
#' Ellipsis, ..., are needed as part of method arguments to allow for its arguments to be different from its generic's
#' arguments and for this to pass check(). Hence, ..., should always be empty. This function will check for this
#' condition.
#'
#' @param ... it should literally just be ...
#' @param stop TRUE to raise an error; FALSE will output warning message
#' @param allowed_args character vector naming arguments that are allowed in the \code{...}.
#'   to allow for unnamed arguments, let "" be one of the elements in this character vector.
#'
#' @return \code{NULL} if ... is empty
#'
#' @keywords internal
#'
#' @examples
#' method.class <- function(a, b, c, ...) {
#'   check_ellipsis(...)
#' }
#' method.class <- function(a, b, c, ...) {
#'   check_ellipsis(..., allowed_args = c("y", "z"))
#' }
check_ellipsis <- function(..., stop = FALSE, allowed_args = character(0)) {
  if (!missing(...)) {
    checkmate::assert_flag(stop)
    checkmate::assert_character(allowed_args, min.len = 0, null.ok = TRUE, any.missing = FALSE)
    args <- list(...)
    arg_names <- names(args)
    if (is.null(arg_names)) {
      arg_names <- rep("", length(args))
    }
    extra_args <- arg_names[!is.element(arg_names, allowed_args)]
    if (length(extra_args) == 0) {
      return(invisible(NULL))
    }
    message <- paste(length(extra_args), "total unused argument(s).")

    named_extra_args <- extra_args[!vapply(extra_args, identical, logical(1), "")]
    if (length(named_extra_args) > 0) {
      message <- paste0(
        message,
        " ",
        length(named_extra_args),
        " with name(s): ",
        paste(named_extra_args, collapse = ", "),
        "."
      )
    }
    if (stop) {
      stop(message)
    } else {
      warning(message)
    }
  }
}

#' Whether the variable name is good to use within Show R Code
#'
#' Spaces are problematic because the variables must be escaped with backticks.
#' Also, they should not start with a number as R may silently make it valid by changing it.
#' Therefore, we only allow alphanumeric characters with underscores.
#' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters.
#'
#' @md
#'
#' @param name `character, single or vector` name to check
#' @keywords internal
#'
#' @examples
#' teal.slice:::check_simple_name("aas2df")
#' teal.slice:::check_simple_name("ADSL")
#' teal.slice:::check_simple_name("ADSLmodified")
#' teal.slice:::check_simple_name("ADSL_modified")
#' teal.slice:::check_simple_name("ADSL_2")
#' teal.slice:::check_simple_name("a1")
#' # the following fail
#' if (interactive()) {
#'   teal.slice:::check_simple_name("1a")
#'   teal.slice:::check_simple_name("ADSL.modified")
#'   teal.slice:::check_simple_name("a1...")
#' }
check_simple_name <- function(name) {
  checkmate::assert_character(name, min.len = 1, any.missing = FALSE)
  if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
    stop(
      "name '",
      name,
      "' must only contain alphanumeric characters (with underscores)",
      " and the first character must be an alphabetic character"
    )
  }
}

#' Resolve the expected bootstrap theme
#' @keywords internal
get_teal_bs_theme <- function() {
  bs_theme <- getOption("teal.bs_theme")
  if (is.null(bs_theme)) {
    NULL
  } else if (!inherits(bs_theme, "bs_theme")) {
    warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
    NULL
  } else {
    bs_theme
  }
}

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

#' 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
#' teal.slice:::make_c_call(1:3)
#' # [1] 1 2 3
#'
#' teal.slice:::make_c_call(1)
#' # [1] 1
#' @keywords internal
make_c_call <- function(choices) {
  if (length(choices) > 1) {
    do.call("call", append(list("c"), choices))
  } else {
    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")

  invisible()
}


### GLOBAL VARIABLES ###

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


### END GLOBAL VARIABLES ###


### ENSURE CHECK PASSES

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


### END ENSURE CHECK PASSES

#' @name FilterStateExpr
#' @docType class
#'
#'
#' @title `FilterStateExpr` Class
#'
#' @description Class to handle filter expression.
#'
#'
#' @details
#' This class is responsible for displaying filter card and returning filter expression
#'
#' @keywords internal
#'
#' @examples
#' filter_state <- teal.slice:::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(),
#'   teal.slice:::include_css_files(pattern = "filter-panel"),
#'   teal.slice:::include_js_files(pattern = "count-bar-labels"),
#'   column(4, div(
#'     h4("ChoicesFilterState"),
#'     filter_state$ui("fs")
#'   )),
#'   column(8, div(
#'     h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
#'     textOutput("condition_choices"), br(),
#'     h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_choices"), br(),
#'     h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_choices"), br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   filter_state$server("fs")
#'   output$condition_choices <- renderPrint(filter_state$get_call())
#'   output$formatted_choices <- renderText(filter_state$format())
#'   output$unformatted_choices <- renderPrint(filter_state$get_state())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
FilterStateExpr <- R6::R6Class( # nolint
  classname = "FilterStateExpr",
  # public methods ----
  public = list(
    #' @description
    #' Initialize a `FilterStateExpr` object
    #' @param slice (`teal_slice_expr`)\cr
    #'   object created by [teal_slice()]
    #' @return `FilterStateExpr`
    initialize = function(slice) {
      checkmate::assert_class(slice, "teal_slice_expr")
      private$teal_slice <- slice
      invisible(self)
    },

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

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

    #' @description
    #' Returns filtering state.
    #'
    #' @return A `teal_slice` object.
    #'
    get_state = function() {
      private$teal_slice
    },

    #' @description
    #' Sets filtering state.
    #'
    #' @param state a `teal_slice` object
    #'
    #' @return `self` invisibly
    #'
    set_state = function(state) {
      checkmate::assert_class(state, "teal_slice_expr")
      invisible(NULL)
    },

    #' @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 `language`
    get_call = function(dataname) {
      shiny::isolate(str2lang(private$teal_slice$expr))
    },

    #' @description
    #' Destroy observers stored in `private$observers`.
    #'
    #' @return NULL invisibly
    #'
    destroy_observers = function() {
      lapply(private$observers, function(x) x$destroy())
      invisible(NULL)
    },

    # public shiny modules ----

    #' @description
    #' Shiny module server.
    #'
    #' @param id (`character(1)`)\cr
    #'   shiny module instance id
    #'
    #' @return `moduleServer` function which returns reactive value
    #'   signaling that remove button has been clicked
    #'
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          private$server_summary("summary")
          out <- reactive(input$remove) # back to parent to remove self
          out
        }
      )
    },

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

  # private members ----

  private = list(
    observers = NULL, # stores observers
    teal_slice = NULL, # stores reactiveValues

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

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

    # @description
    # UI module to display filter summary
    # @param shiny `id` parametr 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() {
      shiny::isolate(private$teal_slice$expr)
    }
  )
)

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

  # public methods ----
  public = list(
    #' @description Initializes `DFFilterStates` object.
    #'
    #' 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`)\cr
    #'   the R object which `dplyr::filter` function is applied on.
    #' @param data_reactive (`function(sid)`)\cr
    #'   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`)\cr
    #'   name of the data used in the \emph{subset expression}
    #'   specified to the function argument attached to this `FilterStates`
    #' @param datalabel (`NULL` or `character(1)`)\cr
    #'   text label value
    #' @param keys (`character`)\cr
    #'   key columns names
    #'
    initialize = function(data,
                          data_reactive = function(sid = "") NULL,
                          dataname,
                          datalabel = NULL,
                          keys = character(0)) {
      checkmate::assert_function(data_reactive, args = "sid")
      checkmate::assert_data_frame(data)
      super$initialize(data, data_reactive, dataname, datalabel)
      private$keys <- keys
      private$set_filterable_varnames(include_varnames = colnames(private$data))
    }
  ),

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

#' Initialize `FilterStates` object
#'
#' Initialize `FilterStates` object
#' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr
#'   the R object which `subset` function is applied on.
#' @param data_reactive (`function(sid)`)\cr
#'   should return an object of the same type as `data` or `NULL`.
#'   This object 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)`)\cr
#'   name of the data used in the expression
#'   specified to the function argument attached to this `FilterStates`.
#' @param datalabel (`character(0)` or `character(1)`)\cr
#'   text label value.
#' @param ... (optional)
#'   additional arguments for specific classes: keys.
#' @keywords internal
#' @export
#' @examples
#' library(shiny)
#' 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 <- teal.slice:::init_filter_states(
#'   data = df,
#'   dataname = "DF"
#' )
#' app <- shinyApp(
#'   ui = fluidPage(
#'     actionButton("clear", span(icon("xmark"), "Remove all filters")),
#'     rf$ui_add(id = "add"),
#'     rf$ui_active("states"),
#'     verbatimTextOutput("expr"),
#'   ),
#'   server = function(input, output, session) {
#'     rf$srv_add(id = "add")
#'     rf$srv_active(id = "states")
#'     output$expr <- renderText({
#'       deparse1(rf$get_call(), collapse = "\n")
#'     })
#'     observeEvent(input$clear, rf$state_list_empty())
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
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 (`object`)\cr
#'   the R object containing elements which class can be checked through `vapply` or `apply`.
#'
#' @examples
#' df <- data.frame(
#'   a = letters[1:3],
#'   b = 1:3,
#'   c = Sys.Date() + 1:3,
#'   d = Sys.time() + 1:3,
#'   z = complex(3)
#' )
#' teal.slice:::get_supported_filter_varnames(df)
#' @return `character` vector of matched element names
#' @keywords internal
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)
  }
}

#' @title Returns a `choices_labeled` object
#'
#' @param data (`data.frame`, `DFrame`, `list`)\cr
#'   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`)\cr
#'  the vector of chosen variables
#' @param varlabels (`character`)\cr
#'  the labels of variables in data
#' @param keys (`character`)\cr
#'  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 <- stats::setNames(variable_types(data = data, columns = choices), choices)
  choice_types[keys] <- "primary_key"

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

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

#' @title `FilterStates` subclass for `MultiAssayExperiments`
#' @description Handles filter states in a `MultiAssayExperiment`
#' @keywords internal
#'
#'
MAEFilterStates <- R6::R6Class( # nolint
  classname = "MAEFilterStates",
  inherit = FilterStates,
  public = list(
    # public methods ----

    #' @description Initializes `MAEFilterStates` object
    #'
    #' Initialize `MAEFilterStates` object
    #'
    #' @param data (`MultiAssayExperiment`)\cr
    #'   the R object which `MultiAssayExperiment::subsetByColData` function is applied on.
    #' @param data_reactive (`function(sid)`)\cr
    #'   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)`)\cr
    #'   name of the data used in the expression
    #'   specified to the function argument attached to this `FilterStates`.
    #' @param datalabel (`NULL` or `character(1)`)\cr
    #'   text label value
    #' @param varlabels (`character`)\cr
    #'   labels of the variables used in this object
    #' @param keys (`character`)\cr
    #'   key columns 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))
      return(invisible(self))
    }
  ),

  # private fields ----

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

# This file contains helper functions used in unit tests.

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


# compare two teal_slice
expect_identical_slice <- function(x, y) {
  shiny::isolate({
    testthat::expect_true(
      setequal(
        reactiveValuesToList(x),
        reactiveValuesToList(y)
      )
    )
  })
}

# compare two teal_slices
expect_identical_slices <- function(x, y) {
  shiny::isolate({
    mapply(
      function(x, y) {
        expect_identical_slice(x, y)
      },
      x = x,
      y = y
    )
    testthat::expect_identical(attributes(x), attributes(y))
  })
}

#' Store teal_slices object to a file
#'
#' This function takes a `teal_slices` object and saves it to a file in `JSON` format.
#' The `teal_slices` object contains information about filter states and can be used to
#' create, modify, and delete filter states. The saved file can be later loaded using
#' the `slices_restore` function.
#'
#' @param tss (`teal_slices`) object to be stored.
#' @param file (`character(1)`) The file path where `teal_slices` object will be saved.
#'  The file extension should be `".json"`.
#'
#' @return `NULL`, invisibly.
#'
#' @examples
#' # Create a teal_slices object
#' tss <- teal_slices(
#'   teal_slice(dataname = "data", varname = "var"),
#'   teal_slice(dataname = "data", expr = "x > 0", id = "positive_x", title = "Positive x")
#' )
#'
#' if (interactive()) {
#'   # Store the teal_slices object to a file
#'   slices_store(tss, "path/to/file.json")
#' }
#'
#' @export
slices_store <- function(tss, file) {
  checkmate::assert_class(tss, "teal_slices")
  checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json")

  cat(format(tss, trim_lines = FALSE), "\n", file = file)
}

#' Restore teal_slices object from a file
#'
#' This function takes a file path to a `JSON` file containing a `teal_slices` object
#' and restores it to its original form. The restored `teal_slices` object can be used
#' to access filter states and their corresponding attributes.
#'
#' @param file Path to file where `teal_slices` is stored. Must have a `.json` extension and read access.
#'
#' @return A `teal_slices` object restored from the file.
#'
#' @examples
#' if (interactive()) {
#'   # Restore a teal_slices object from a file
#'   tss_restored <- slices_restore("path/to/file.json")
#' }
#' @export
slices_restore <- function(file) {
  checkmate::assert_file_exists(file, access = "r", extension = "json")

  tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE)

  tss_elements <- lapply(tss_json$slices, as.teal_slice)

  do.call(teal_slices, c(tss_elements, tss_json$attributes))
}

#' 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
  )
  return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))
}

1		#' Initializes `FilteredDataset`
2		#'
3		#' @keywords internal
4		#' @examples
5		#' # DefaultFilteredDataset example
6		#' iris_fd <- teal.slice:::init_filtered_dataset(
7		#' iris,
8		#' dataname = "iris",
9		#' metadata = list(type = "teal")
10		#' )
11		#' app <- shinyApp(
12		#' ui = fluidPage(
13		#' iris_fd$ui_add(id = "add"),
14		#' iris_fd$ui_active("dataset"),
15		#' verbatimTextOutput("call"),
16		#' verbatimTextOutput("metadata")
17		#' ),
18		#' server = function(input, output, session) {
19		#' iris_fd$srv_add(id = "add")
20		#' iris_fd$srv_active(id = "dataset")
21		#'
22		#' output$metadata <- renderText({
23		#' paste("Type =", iris_fd$get_metadata()$type)
24		#' })
25		#'
26		#' output$call <- renderText({
27		#' paste(
28		#' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),
29		#' collapse = "\n"
30		#' )
31		#' })
32		#' }
33		#' )
34		#' if (interactive()) {
35		#' runApp(app)
36		#' }
37		#'
38		#' # MAEFilteredDataset example
39		#' library(MultiAssayExperiment)
40		#' data(miniACC)
41		#' MAE_fd <- teal.slice:::init_filtered_dataset(miniACC, "MAE", metadata = list(type = "MAE"))
42		#' app <- shinyApp(
43		#' ui = fluidPage(
44		#' MAE_fd$ui_add(id = "add"),
45		#' MAE_fd$ui_active("dataset"),
46		#' verbatimTextOutput("call"),
47		#' verbatimTextOutput("metadata")
48		#' ),
49		#' server = function(input, output, session) {
50		#' MAE_fd$srv_add(id = "add")
51		#' MAE_fd$srv_active(id = "dataset")
52		#' output$metadata <- renderText({
53		#' paste("Type =", MAE_fd$get_metadata()$type)
54		#' })
55		#' output$call <- renderText({
56		#' paste(
57		#' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),
58		#' collapse = "\n"
59		#' )
60		#' })
61		#' }
62		#' )
63		#' if (interactive()) {
64		#' runApp(app)
65		#' }
66		#' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr
67		#' @param dataname (`character`)\cr
68		#' A given name for the dataset it may not contain spaces
69		#' @param keys optional, (`character`)\cr
70		#' Vector with primary keys
71		#' @param parent_name (`character(1)`)\cr
72		#' Name of the parent dataset
73		#' @param parent (`reactive`)\cr
74		#' object returned by this reactive is a filtered `data.frame` from other `FilteredDataset`
75		#' named `parent_name`. Consequence of passing `parent` is a `reactive` link which causes
76		#' causing re-filtering of this `dataset` based on the changes in `parent`.
77		#' @param join_keys (`character`)\cr
78		#' Name of the columns in this dataset to join with `parent`
79		#' dataset. If the column names are different if both datasets
80		#' then the names of the vector define the `parent` columns.
81		#' @param label (`character`)\cr
82		#' Label to describe the dataset
83		#' @param metadata (named `list` or `NULL`) \cr
84		#' Field containing metadata about the dataset. Each element of the list
85		#' should be atomic and length one.
86		#' @export
87		#' @note Although this function is exported for use in other packages, it may be changed or removed in a future release
88		#' at which point any code which relies on this exported function will need to be changed.
89		init_filtered_dataset <- function(dataset, # nolint
90		dataname,
91		keys = character(0),
92		parent_name = character(0),
93		parent = reactive(dataset),
94		join_keys = character(0),
95		label = attr(dataset, "label"),
96		metadata = NULL) {
97	104x	UseMethod("init_filtered_dataset")
98		}
99
100		#' @keywords internal
101		#' @export
102		init_filtered_dataset.data.frame <- function(dataset, # nolint
103		dataname,
104		keys = character(0),
105		parent_name = character(0),
106		parent = NULL,
107		join_keys = character(0),
108		label = attr(dataset, "label"),
109		metadata = NULL) {
110	95x	DefaultFilteredDataset$new(
111	95x	dataset = dataset,
112	95x	dataname = dataname,
113	95x	keys = keys,
114	95x	parent_name = parent_name,
115	95x	parent = parent,
116	95x	join_keys = join_keys,
117	95x	label = label,
118	95x	metadata = metadata
119		)
120		}
121
122		#' @keywords internal
123		#' @export
124		init_filtered_dataset.MultiAssayExperiment <- function(dataset, # nolint
125		dataname,
126		keys = character(0),
127		parent_name, # ignored
128		parent, # ignored
129		join_keys, # ignored
130		label = attr(dataset, "label"),
131		metadata = NULL) {
132	9x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
133	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
134		}
135	9x	MAEFilteredDataset$new(
136	9x	dataset = dataset,
137	9x	dataname = dataname,
138	9x	keys = keys,
139	9x	label = label,
140	9x	metadata = metadata
141		)
142		}

1		#' Specify single filter.
2		#'
3		#' Create a `teal_slice` object that holds complete information on filtering one variable.
4		#'
5		#' @details
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 (optional `vector`) specifying 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.
62		#' @param selected (optional `vector`) of selected values from `choices`;
63		#' Type and size depends on variable type.
64		#' @param multiple (optional `logical(1)`) flag specifying whether more than one value can be selected;
65		#' only applicable to `ChoicesFilterState` and `LogicalFilterState`
66		#' @param keep_na (optional `logical(1)`) flag specifying whether to keep missing values
67		#' @param keep_inf (optional `logical(1)`) 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 (optional `character(1)`) title of the filter. Ignored when `varname` is set.
71		#' @param ... in `teal_slice` method these are additional arguments which can be handled by extensions
72		#' of `teal.slice` classes. In other methods these are further arguments passed to or from other methods.
73		#' @param x (`teal.slice`) object.
74		#' @param show_all (`logical(1)`) indicating whether to show all fields. If set to `FALSE`,
75		#' only non-NULL elements will be printed.
76		#' @param trim_lines (`logical(1)`) indicating whether to trim lines when printing.
77		#'
78		#' @return A `teal.slice` object. Depending on whether `varname` or `expr` was specified, the resulting
79		#' `teal_slice` also receives class `teal_slice_var` or `teal_slice_expr`, respectively.
80		#'
81		#' @examples
82		#' x1 <- teal_slice(
83		#' dataname = "data",
84		#' id = "Female adults",
85		#' expr = "SEX == 'F' & AGE >= 18",
86		#' title = "Female adults"
87		#' )
88		#' x2 <- teal_slice(
89		#' dataname = "data",
90		#' varname = "var",
91		#' choices = c("F", "M", "U"),
92		#' selected = "F",
93		#' keep_na = TRUE,
94		#' keep_inf = TRUE,
95		#' fixed = FALSE,
96		#' anchored = FALSE,
97		#' multiple = TRUE,
98		#' id = "Gender",
99		#' extra_arg = "extra"
100		#' )
101		#'
102		#' is.teal_slice(x1)
103		#' as.list(x1)
104		#' as.teal_slice(list(dataname = "a", varname = "var"))
105		#' format(x1)
106		#' format(x1, show_all = TRUE, trim_lines = FALSE)
107		#' print(x1)
108		#' print(x1, show_all = TRUE, trim_lines = FALSE)
109		#'
110		#' @seealso [`teal_slices`]
111		#'
112		#' @export
113		teal_slice <- function(dataname,
114		varname,
115		id,
116		expr,
117		choices = NULL,
118		selected = NULL,
119		keep_na = NULL,
120		keep_inf = NULL,
121		fixed = FALSE,
122		anchored = FALSE,
123		multiple = TRUE,
124		title = NULL,
125		...) {
126	588x	checkmate::assert_string(dataname)
127	581x	checkmate::assert_flag(fixed)
128	579x	checkmate::assert_flag(anchored)
129
130	577x	formal_args <- as.list(environment())
131
132	577x	if (!missing(expr) && !missing(varname)) {
133	!	stop("Must provide either `expr` or `varname`.")
134	577x	} else if (!missing(expr)) {
135	30x	checkmate::assert_string(id)
136	27x	checkmate::assert_string(title)
137	24x	checkmate::assert_string(expr)
138
139	23x	formal_args$fixed <- TRUE
140	23x	ts_expr_args <- c("dataname", "id", "expr", "fixed", "anchored", "title")
141	23x	formal_args <- formal_args[ts_expr_args]
142	23x	ans <- do.call(shiny::reactiveValues, c(formal_args, list(...)))
143	23x	class(ans) <- c("teal_slice_expr", "teal_slice", class(ans))
144	547x	} else if (!missing(varname)) {
145	546x	checkmate::assert_string(varname)
146	543x	checkmate::assert_multi_class(choices, .filterable_class, null.ok = TRUE)
147	542x	checkmate::assert_multi_class(selected, .filterable_class, null.ok = TRUE)
148	540x	checkmate::assert_flag(keep_na, null.ok = TRUE)
149	539x	checkmate::assert_flag(keep_inf, null.ok = TRUE)
150	538x	checkmate::assert_flag(multiple)
151
152	538x	ts_var_args <- c(
153	538x	"dataname", "varname", "id", "choices", "selected", "keep_na", "keep_inf",
154	538x	"fixed", "anchored", "multiple"
155		)
156	538x	formal_args <- formal_args[ts_var_args]
157	538x	args <- c(formal_args, list(...))
158	538x	if (missing(id)) {
159	529x	args$id <- get_default_slice_id(args)
160		} else {
161	9x	checkmate::assert_string(id)
162		}
163	535x	ans <- do.call(shiny::reactiveValues, args)
164	535x	class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
165		} else {
166	1x	stop("Must provide either `expr` or `varname`.")
167		}
168
169	558x	ans
170		}
171
172		#' @rdname teal_slice
173		#' @export
174		#' @keywords internal
175		#'
176		is.teal_slice <- function(x) { # nolint
177	4x	inherits(x, "teal_slice")
178		}
179
180		#' @rdname teal_slice
181		#' @export
182		#' @keywords internal
183		#'
184		as.teal_slice <- function(x) { # nolint
185	7x	checkmate::assert_list(x, names = "named")
186	7x	do.call(teal_slice, x)
187		}
188
189		#' @rdname teal_slice
190		#' @export
191		#' @keywords internal
192		#'
193		as.list.teal_slice <- function(x, ...) {
194	297x	formal_args <- setdiff(names(formals(teal_slice)), "...")
195
196	297x	x <- if (shiny::isRunning()) {
197	!	shiny::reactiveValuesToList(x)
198		} else {
199	297x	shiny::isolate(shiny::reactiveValuesToList(x))
200		}
201
202	297x	formal_args <- intersect(formal_args, names(x))
203	297x	extra_args <- rev(setdiff(names(x), formal_args))
204
205	297x	x[c(formal_args, extra_args)]
206		}
207
208
209		#' @rdname teal_slice
210		#' @export
211		#' @keywords internal
212		#'
213		format.teal_slice <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
214	116x	checkmate::assert_flag(show_all)
215	92x	checkmate::assert_flag(trim_lines)
216
217	86x	x_list <- as.list(x)
218	47x	if (!show_all) x_list <- Filter(Negate(is.null), x_list)
219
220	86x	jsonify(x_list, trim_lines)
221		}
222
223		#' @rdname teal_slice
224		#' @export
225		#' @keywords internal
226		#'
227		print.teal_slice <- function(x, ...) {
228	15x	cat(format(x, ...))
229		}
230
231
232		# format utils -----
233
234		#' Convert a list to a justified `JSON` string
235		#'
236		#' This function takes a list and converts it to a `JSON` string.
237		#' The resulting `JSON` string is then optionally justified to improve readability
238		#' and trimmed to easier fit in the console when printing.
239		#'
240		#' @param x (`list`), possibly recursive, obtained from `teal_slice` or `teal_slices`.
241		#' @param trim_lines (`logical(1)`) flag specifying whether to trim lines of the `JSON` string.
242		#' @return A `JSON` string representation of the input list.
243		#' @keywords internal
244		#'
245		jsonify <- function(x, trim_lines) {
246	135x	checkmate::assert_list(x)
247
248	135x	x_json <- to_json(x)
249	135x	x_json_justified <- justify_json(x_json)
250	123x	if (trim_lines) x_json_justified <- trim_lines_json(x_json_justified)
251	135x	paste(x_json_justified, collapse = "\n")
252		}
253
254		#' Converts a list to a `JSON` string
255		#'
256		#' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string.
257		#' Ensures proper unboxing of list elements.
258		#' This function is used by the `format` methods for `teal_slice` and `teal_slices`.
259		#' @param x `list`, possibly recursive, obtained from `teal_slice` or `teal_slices`.
260		#' @return A `JSON` string.
261		#' @keywords internal
262		#
263		#' @param x (`list`) representation of `teal_slices` object.
264		#' @keywords internal
265		#'
266		to_json <- function(x) {
267	135x	no_unbox <- function(x) {
268	2578x	vars <- c("selected", "choices")
269	2578x	if (is.list(x)) {
270	419x	for (var in vars) {
271	335x	if (!is.null(x[[var]])) x[[var]] <- I(x[[var]])
272		}
273	419x	lapply(x, no_unbox)
274		} else {
275	2159x	x
276		}
277		}
278
279	135x	jsonlite::toJSON(no_unbox(x), pretty = TRUE, auto_unbox = TRUE, digits = 16, null = "null")
280		}
281
282		#' Justify Colons in `JSON` String
283		#'
284		#' This function takes a `JSON` string as input, splits it into lines, and pads element names
285		#' with spaces so that colons are justified between lines.
286		#'
287		#' @param json (`character(1)`) a `JSON` string.
288		#'
289		#' @return A list of character strings, which can be collapsed into a `JSON` string.
290		#'
291		#' @keywords internal
292		justify_json <- function(json) {
293	135x	format_name <- function(name, name_width) {
294	2997x	if (nchar(name) == 1 \|\| nchar(gsub("\\s", "", name)) <= 2) {
295	682x	return(name)
296	2315x	} else if (grepl("slices\|attributes", name)) {
297	98x	paste0(name, ":")
298		} else {
299	2217x	paste(format(name, width = name_width), ":")
300		}
301		}
302	135x	json_lines <- strsplit(json, "\n")[[1]]
303	135x	json_lines_split <- regmatches(json_lines, regexpr(":", json_lines), invert = TRUE)
304	135x	name_width <- max(unlist(regexpr(":", json_lines))) - 1
305	135x	vapply(json_lines_split, function(x) paste0(format_name(x[1], name_width), stats::na.omit(x[2])), character(1))
306		}
307
308		#' Trim Lines in `JSON` String
309		#'
310		#' This function takes a `JSON` string as input and returns a modified version of the
311		#' input where the values portion of each line is trimmed for a less messy console output.
312		#'
313		#' @param x A character string.
314		#'
315		#' @return A character string trimmed after a certain hard-coded number of characters in the value portion.
316		#'
317		#' @keywords internal
318		#'
319		trim_lines_json <- function(x) {
320	123x	name_width <- max(unlist(gregexpr(":", x))) - 1
321	123x	trim_position <- name_width + 37L
322	123x	x_trim <- substr(x, 1, trim_position)
323	123x	substr(x_trim, trim_position - 2, trim_position) <- "..."
324	123x	x_trim
325		}
326
327		#' Default `teal_slice` id
328		#'
329		#' Function returns a default `id` for a `teal_slice` object which needs
330		#' to be distinct from other `teal_slice` objects created for any
331		#' `FilterStates` object. Returned `id` can be treated as a location of
332		#' a vector on which `FilterState` is built:
333		#' - for a `data.frame` `id` concatenates `dataname` and `varname`.
334		#' - for a `MultiAssayExperiment` `id` concatenates `dataname`, `varname`,
335		#' `experiment` and `arg`, so that one can add `teal_slice` for a `varname`
336		#' which exists in multiple `SummarizedExperiment`s or exists in both `colData`
337		#' and `rowData` of given experiment.
338		#' For such a vector `teal.slice` doesn't allow to activate more than one filters.
339		#'
340		#' In case of `teal_slice_expr` `id` is mandatory and must be unique.
341		#' @param x (`teal_slice` or `list`)
342		#' @return (`character(1)`) `id` for a `teal_slice` object.
343		#' @keywords internal
344		get_default_slice_id <- function(x) {
345	618x	checkmate::assert_multi_class(x, c("teal_slice", "list"))
346	618x	shiny::isolate({
347	618x	if (inherits(x, "teal_slice_expr") \|\| is.null(x$varname)) {
348	10x	x$id
349		} else {
350	608x	paste(
351	608x	Filter(
352	608x	length,
353	608x	as.list(x)[c("dataname", "varname", "experiment", "arg")]
354		),
355	608x	collapse = " "
356		)
357		}
358		})
359		}

1		#' Progress bars with labels
2		#'
3		#' `shiny` element showing progress bar counts. Each element can have an
4		#' unique `id` attribute so each can be used independently.
5		#' Progress bar size is dependent on the ratio `choicesnow[i] / countsmax[i]`.
6		#' Label is `choices[i] (countsnow[i]/countsmax)`
7		#' @param session (`session`) object passed to function given to `shinyServer`.
8		#' @param inputId (`character(1)`) `shiny` id
9		#' @param choices (`vector`) determines label text.
10		#' @param countsmax (`numeric`) determining maximal count of each element.
11		#' Length should be the same as `choices`.
12		#' @param countsnow (`numeric`) actual counts of each element.
13		#' Length should be the same as `choices`.
14		#' @return list of `shiny.tag`
15		#' @examples
16		#'
17		#' choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE)
18		#' counts <- table(choices)
19		#' labels <- teal.slice:::countBars(
20		#' inputId = "counts",
21		#' choices = c("a", "b", "c"),
22		#' countsmax = counts,
23		#' countsnow = unname(counts)
24		#' )
25		#'
26		#' app <- shinyApp(
27		#' ui = fluidPage(
28		#' div(
29		#' class = "choices_state",
30		#' teal.slice:::include_js_files("count-bar-labels.js"),
31		#' teal.slice:::include_css_files(pattern = "filter-panel"),
32		#' checkboxGroupInput(
33		#' inputId = "choices",
34		#' selected = levels(choices),
35		#' choiceNames = labels,
36		#' choiceValues = levels(choices),
37		#' label = NULL
38		#' )
39		#' )
40		#' ),
41		#' server = function(input, output, session) {
42		#' observeEvent(input$choices, {
43		#' new_counts <- counts
44		#' new_counts[!names(new_counts) %in% input$choices] <- 0
45		#' teal.slice:::updateCountBars(
46		#' inputId = "counts",
47		#' choices = levels(choices),
48		#' countsmax = counts,
49		#' countsnow = unname(new_counts)
50		#' )
51		#' })
52		#' }
53		#' )
54		#' if (interactive()) {
55		#' runApp(app)
56		#' }
57		#' @keywords internal
58		countBars <- function(inputId, choices, countsmax, countsnow = NULL) { # nolint
59	25x	checkmate::assert_string(inputId)
60	21x	checkmate::assert_vector(choices)
61	20x	checkmate::assert_numeric(countsmax, len = length(choices))
62	17x	checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)
63	15x	if (!is.null(countsnow)) {
64	7x	checkmate::assert_true(all(countsnow <= countsmax))
65		}
66
67	14x	ns <- NS(inputId)
68	14x	counttotal <- sum(countsmax)
69
70	14x	mapply(
71	14x	countBar,
72	14x	inputId = ns(seq_along(choices)),
73	14x	label = as.character(choices),
74	14x	countmax = countsmax,
75	14x	countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
76	14x	MoreArgs = list(
77	14x	counttotal = sum(countsmax)
78		),
79	14x	SIMPLIFY = FALSE, USE.NAMES = FALSE
80		)
81		}
82
83		#' Progress bar with label
84		#'
85		#' Progress bar with label
86		#' @param session (`session`) object passed to function given to `shinyServer`.
87		#' @param inputId (`character(1)`) `shiny` id
88		#' @param label (`character(1)`) Text to display followed by counts
89		#' @param countmax (`numeric(1)`) maximal possible count for a single item.
90		#' @param countnow (`numeric(1)`) current count of a single item.
91		#' @param counttotal (`numeric(1)`) total count to make whole progress bar
92		#' taking part of the container. Ratio between `countmax / counttotal`
93		#' determines `<style="width: <countmax / counttotal>%""`.
94		#' @return `shiny.tag` object with a progress bar and a label.
95		#' @keywords internal
96		countBar <- function(inputId, label, countmax, countnow = NULL, counttotal = countmax) { # nolint
97	62x	checkmate::assert_string(inputId)
98	58x	checkmate::assert_string(label)
99	55x	checkmate::assert_number(countmax)
100	53x	checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax)
101	51x	checkmate::assert_number(counttotal, lower = countmax)
102
103	49x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
104	49x	ns <- NS(inputId)
105	26x	if (is.null(countnow)) countnow <- 0
106	49x	tags$div(
107	49x	class = "progress state-count-container",
108		# * .9 to not exceed width of the parent html element
109	49x	tags$div(
110	49x	id = ns("count_bar_filtered"),
111	49x	class = "progress-bar state-count-bar-filtered",
112	49x	style = sprintf("width: %s%%", countnow / counttotal * 100),
113	49x	role = "progressbar",
114	49x	label
115		),
116	49x	tags$div(
117	49x	id = ns("count_bar_unfiltered"),
118	49x	class = "progress-bar state-count-bar-unfiltered",
119	49x	style = sprintf("width: %s%%", (countmax - countnow) / counttotal * 100),
120	49x	role = "progressbar"
121		)
122		)
123		}
124
125		#' @rdname countBars
126		updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, # nolint
127		countsmax, countsnow = NULL) {
128	7x	checkmate::assert_string(inputId)
129	7x	checkmate::assert_vector(choices)
130	7x	checkmate::assert_numeric(countsmax, len = length(choices))
131	7x	checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)
132
133	7x	ns <- NS(inputId)
134	7x	mapply(
135	7x	updateCountBar,
136	7x	inputId = ns(seq_along(choices)),
137	7x	label = choices,
138	7x	countmax = countsmax,
139	7x	countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,
140	7x	MoreArgs = list(
141	7x	counttotal = sum(countsmax)
142		)
143		)
144	7x	invisible(NULL)
145		}
146
147		#' @rdname countBar
148		updateCountBar <- function(session = getDefaultReactiveDomain(), inputId, label, # nolint
149		countmax, countnow = NULL, counttotal) {
150	18x	checkmate::assert_string(inputId)
151	18x	checkmate::assert_string(label)
152	18x	checkmate::assert_number(countmax)
153	18x	checkmate::assert_number(countnow, null.ok = TRUE)
154	18x	checkmate::assert_number(counttotal)
155
156	18x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
157	18x	if (is.null(countnow)) countnow <- countmax
158	18x	session$sendCustomMessage(
159	18x	type = "updateCountBar",
160	18x	message = list(
161	18x	id = session$ns(inputId),
162	18x	label = label,
163	18x	countmax = countmax,
164	18x	countnow = countnow,
165	18x	counttotal = counttotal
166		)
167		)
168
169	18x	invisible(NULL)
170		}
171
172		#' @rdname countBar
173		updateCountText <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow) { # nolint
174	17x	checkmate::assert_string(inputId)
175	17x	checkmate::assert_string(label)
176	17x	checkmate::assert_number(countmax)
177	17x	checkmate::assert_number(countnow, null.ok = TRUE)
178	17x	label <- make_count_text(label, countmax = countmax, countnow = countnow)
179	17x	session$sendCustomMessage(
180	17x	type = "updateCountText",
181	17x	message = list(
182	17x	id = session$ns(inputId),
183	17x	label = label
184		)
185		)
186		}
187
188		#' Make a count text
189		#'
190		#' Returns a text describing filtered counts. The text is composed in the following way:
191		#' - when `countnow` is not `NULL`: `<label> (<countnow>/<countmax>)`
192		#' - when `countnow` is `NULL`: `<label> (<countmax>)`
193		#' @param label (`character(1)`) Text displayed before counts
194		#' @param countnow (`numeric(1)`) filtered counts
195		#' @param countmax (`numeric(1)`) unfiltered counts
196		#' @return `character(1)`
197		#' @keywords internal
198		make_count_text <- function(label, countmax, countnow = NULL) {
199	96x	checkmate::assert_string(label)
200	94x	checkmate::assert_number(countmax)
201	92x	checkmate::assert_number(countnow, null.ok = TRUE)
202	90x	sprintf(
203	90x	"%s (%s%s)",
204	90x	label,
205	90x	if (is.null(countnow)) "" else sprintf("%s/", countnow),
206	90x	countmax
207		)
208		}

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

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

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

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

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

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

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

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

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

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

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

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

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

1		#' Complete filter specification.
2		#'
3		#' Create `teal_slices` object to package multiple filters and additional settings.
4		#'
5		#' @details
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. For `print` and `format`,
17		#' additional arguments passed to other functions.
18		#' @param include_varnames,exclude_varnames (`named list`s of `character`) where list names
19		#' match names of data sets and vector elements match variable names in respective data sets;
20		#' specify which variables are allowed to be filtered; see `Details`
21		#' @param count_type `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
22		#' (`character(1)`) string specifying how observations are tallied by these filter states.
23		#' Possible options:
24		#' - `"none"` (default) to have counts of single `FilterState` to show unfiltered number only.
25		#' - `"all"` to have counts of single `FilterState` to show number of observation in filtered
26		#' and unfiltered dataset. Note, that issues were reported when using this option with `MultiAssayExperiment`.
27		#' Please make sure that adding new filters doesn't fail on target platform before deploying for production.
28		#' @param allow_add (`logical(1)`) logical flag specifying whether the user will be able to add new filters
29		#' @param x object to test for `teal_slices`, object to convert to `teal_slices` or a `teal_slices` object
30		#' @param i (`character` or `numeric` or `logical`) indicating which elements to extract
31		#' @param recursive (`logical(1)`) flag specifying whether to also convert to list the elements of this `teal_slices`
32		#'
33		#' @return
34		#' `teal_slices`, which is an unnamed list of `teal_slice` objects.
35		#'
36		#' @examples
37		#' filter_1 <- teal_slice(
38		#' dataname = "dataname1",
39		#' varname = "varname1",
40		#' choices = letters,
41		#' selected = "b",
42		#' keep_na = TRUE,
43		#' fixed = FALSE,
44		#' extra1 = "extraone"
45		#' )
46		#' filter_2 <- teal_slice(
47		#' dataname = "dataname1",
48		#' varname = "varname2",
49		#' choices = 1:10,
50		#' keep_na = TRUE,
51		#' selected = 2,
52		#' fixed = TRUE,
53		#' anchored = FALSE,
54		#' extra2 = "extratwo"
55		#' )
56		#' filter_3 <- teal_slice(
57		#' dataname = "dataname2",
58		#' varname = "varname3",
59		#' choices = 1:10 / 10,
60		#' keep_na = TRUE,
61		#' selected = 0.2,
62		#' fixed = TRUE,
63		#' anchored = FALSE,
64		#' extra1 = "extraone",
65		#' extra2 = "extratwo"
66		#' )
67		#'
68		#' all_filters <- teal_slices(
69		#' filter_1,
70		#' filter_2,
71		#' filter_3,
72		#' exclude_varnames = list(
73		#' "dataname1" = "varname2"
74		#' )
75		#' )
76		#'
77		#' is.teal_slices(all_filters)
78		#' all_filters[1:2]
79		#' c(all_filters[1], all_filters[2])
80		#' print(all_filters)
81		#' print(all_filters, trim_lines = FALSE)
82		#'
83		#' @seealso [`teal_slice`]
84		#'
85		#' @export
86		#'
87		teal_slices <- function(...,
88		exclude_varnames = NULL,
89		include_varnames = NULL,
90		count_type = NULL,
91		allow_add = TRUE) {
92	775x	slices <- list(...)
93	775x	checkmate::assert_list(slices, types = "teal_slice", any.missing = FALSE)
94	774x	slices_id <- shiny::isolate(vapply(slices, `[[`, character(1L), "id"))
95	774x	if (any(duplicated(slices_id))) {
96	1x	stop(
97	1x	"Some teal_slice objects have the same id:\n",
98	1x	toString(unique(slices_id[duplicated(slices_id)]))
99		)
100		}
101	773x	checkmate::assert_list(exclude_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)
102	772x	checkmate::assert_list(include_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)
103	771x	checkmate::assert_character(count_type, len = 1, null.ok = TRUE)
104	769x	checkmate::assert_subset(count_type, choices = c("all", "none"), empty.ok = TRUE)
105	768x	checkmate::assert_logical(allow_add)
106
107	767x	duplicated_datasets <- intersect(names(include_varnames), names(exclude_varnames))
108	767x	if (length(duplicated_datasets)) {
109	1x	stop(
110	1x	"Some datasets are specified in both, include_varnames and exclude_varnames:\n",
111	1x	toString(duplicated_datasets)
112		)
113		}
114
115	766x	structure(
116	766x	slices,
117	766x	exclude_varnames = exclude_varnames,
118	766x	include_varnames = include_varnames,
119	766x	count_type = count_type,
120	766x	allow_add = allow_add,
121	766x	class = c("teal_slices", class(slices))
122		)
123		}
124
125
126		#' @rdname teal_slices
127		#' @export
128		#' @keywords internal
129		#'
130		is.teal_slices <- function(x) { # nolint
131	523x	inherits(x, "teal_slices")
132		}
133
134
135		#' @rdname teal_slices
136		#' @export
137		#' @keywords internal
138		#'
139		as.teal_slices <- function(x) { # nolint
140	!	checkmate::assert_list(x)
141	!	lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")
142
143	!	attrs <- attributes(unclass(x))
144	!	ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))
145	!	do.call(teal_slices, c(ans, attrs))
146		}
147
148
149		#' @rdname teal_slices
150		#' @export
151		#' @keywords internal
152		#'
153		as.list.teal_slices <- function(x, recursive = FALSE, ...) { # nolint
154	1115x	ans <- unclass(x)
155	49x	if (recursive) ans[] <- lapply(ans, as.list)
156	1115x	ans
157		}
158
159
160		#' @rdname teal_slices
161		#' @export
162		#' @keywords internal
163		#'
164		`[.teal_slices` <- function(x, i) {
165	3x	if (missing(i)) i <- seq_along(x)
166	551x	if (length(i) == 0L) {
167	197x	return(x[0])
168		}
169	1x	if (is.logical(i) && length(i) > length(x)) stop("subscript out of bounds")
170	1x	if (is.numeric(i) && max(i) > length(x)) stop("subscript out of bounds")
171	352x	if (is.character(i)) {
172	1x	if (!all(is.element(i, names(x)))) stop("subscript out of bounds")
173	2x	i <- which(is.element(i, names(x)))
174		}
175
176	351x	y <- NextMethod("[")
177	351x	attrs <- attributes(x)
178	351x	attrs$names <- attrs$names[i]
179	351x	attributes(y) <- attrs
180	351x	y
181		}
182
183
184		#' @rdname teal_slices
185		#' @export
186		#' @keywords internal
187		#'
188		c.teal_slices <- function(...) {
189	258x	x <- list(...)
190	258x	checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")
191
192	257x	excludes <- lapply(x, attr, "exclude_varnames")
193	257x	names(excludes) <- NULL
194	257x	excludes <- unlist(excludes, recursive = FALSE)
195	257x	excludes <- excludes[!duplicated(names(excludes))]
196
197	257x	includes <- lapply(x, attr, "include_varnames")
198	257x	names(includes) <- NULL
199	257x	includes <- unlist(includes, recursive = FALSE)
200	257x	includes <- includes[!duplicated(names(includes))]
201
202	257x	count_types <- lapply(x, attr, "count_type")
203	257x	count_types <- unique(unlist(count_types))
204
205	257x	do.call(
206	257x	teal_slices,
207	257x	c(
208	257x	unique(unlist(x, recursive = FALSE)),
209	257x	list(
210	257x	include_varnames = if (length(includes)) includes,
211	257x	exclude_varnames = if (length(excludes)) excludes,
212	257x	count_type = count_types
213		)
214		)
215		)
216		}
217
218
219		#' @rdname teal_slices
220		#' @param show_all (`logical(1)`) whether to display non-null elements of constituent `teal_slice` objects
221		#' @param trim_lines (`logical(1)`) whether to trim lines
222		#' @export
223		#' @keywords internal
224		#'
225		format.teal_slices <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
226	49x	checkmate::assert_flag(show_all)
227	49x	checkmate::assert_flag(trim_lines)
228
229	49x	x <- as.list(x, recursive = TRUE)
230	49x	attrs <- attributes(x)
231	49x	attributes(x) <- NULL
232	49x	slices_list <- list(slices = x, attributes = attrs)
233	49x	slices_list <- Filter(Negate(is.null), slices_list) # drop attributes if empty
234
235	22x	if (!show_all) slices_list$slices <- lapply(slices_list$slices, function(slice) Filter(Negate(is.null), slice))
236
237	49x	jsonify(slices_list, trim_lines)
238		}
239
240
241		#' @rdname teal_slices
242		#' @export
243		#' @keywords internal
244		#'
245		print.teal_slices <- function(x, ...) {
246	5x	cat(format(x, ...), "\n")
247		}
248
249
250		#' `setdiff` method for `teal_slices`
251		#'
252		#' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`.
253		#' @param x,y `teal_slices` objects
254		#' @return `teal_slices`
255		#' @keywords internal
256		#'
257		setdiff_teal_slices <- function(x, y) {
258	14x	Filter(
259	14x	function(xx) {
260	12x	!any(vapply(y, function(yy) identical(yy, xx), logical(1)))
261		},
262	14x	x
263		)
264		}
265
266
267		#' @rdname teal_slices
268		#' @export
269		#' @keywords internal
270		#'
271		list_to_teal_slices <- function(x) { # nolint
272	1x	checkmate::assert_list(x, names = "named")
273	1x	is_bottom <- function(x) {
274	10x	isTRUE(is.list(x) && any(names(x) %in% c("selected", "keep_na", "keep_inf"))) \|\|
275	10x	identical(x, list()) \|\|
276	10x	is.atomic(x)
277		}
278	1x	make_args <- function(object, dataname, varname, experiment = NULL, arg = NULL) {
279	7x	args <- list(
280	7x	dataname = dataname,
281	7x	varname = varname
282		)
283	1x	if (!is.null(experiment)) args$experiment <- experiment
284	1x	if (!is.null(arg)) args$arg <- arg
285	7x	if (is.list(object)) {
286	6x	args <- c(args, object)
287	1x	} else if (is.atomic(object)) {
288	1x	args$selected <- object
289		}
290	7x	args
291		}
292	1x	slices <- vector("list")
293
294	1x	for (dataname in names(x)) {
295	2x	item <- x[[dataname]]
296	2x	for (name_i in names(item)) {
297	5x	subitem <- item[[name_i]]
298	5x	if (is_bottom(subitem)) {
299	3x	args <- make_args(
300	3x	subitem,
301	3x	dataname = dataname,
302	3x	varname = name_i
303		)
304	3x	slices <- c(slices, list(as.teal_slice(args)))
305		} else {
306		# MAE zone
307	2x	for (name_ii in names(subitem)) {
308	4x	subsubitem <- subitem[[name_ii]]
309	4x	if (is_bottom(subsubitem)) {
310	3x	args <- make_args(
311	3x	subsubitem,
312	3x	dataname = dataname,
313	3x	experiment = if (name_i != "subjects") name_i,
314	3x	varname = name_ii
315		)
316	3x	slices <- c(slices, list(as.teal_slice(args)))
317		} else {
318	1x	for (name_iii in names(subsubitem)) {
319	1x	subsubsubitem <- subsubitem[[name_iii]]
320	1x	if (is_bottom(subsubsubitem)) {
321	1x	args <- make_args(
322	1x	subsubsubitem,
323	1x	dataname = dataname,
324	1x	experiment = name_i,
325	1x	arg = name_ii,
326	1x	varname = name_iii
327		)
328	1x	slices <- c(slices, list(as.teal_slice(args)))
329		}
330		}
331		}
332		}
333		}
334		}
335		}
336
337	1x	if (length(slices) == 0L && length(x) != 0L) {
338	!	stop("conversion to filter_slices failed")
339		}
340
341	1x	do.call(teal_slices, c(slices, list(include_varnames = attr(x, "filterable"))))
342		}

1		#' Get classes of selected columns from dataset
2		#'
3		#' @param data (`data.frame`) data to determine variable types from
4		#' @param columns (atomic vector of `character` or `NULL`) column names chosen from `data`.
5		#' The value of `NULL` will be interpreted to mean all columns.
6		#'
7		#' @return (atomic vector of `character`) classes of `columns` from provided `data`
8		#' @keywords internal
9		#' @examples
10		#' teal.slice:::variable_types(
11		#' data.frame(
12		#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
13		#' stringsAsFactors = FALSE
14		#' ),
15		#' "x"
16		#' )
17		#'
18		#' teal.slice:::variable_types(
19		#' data.frame(
20		#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
21		#' stringsAsFactors = FALSE
22		#' ),
23		#' c("x", "z")
24		#' )
25		#'
26		#' teal.slice:::variable_types(
27		#' data.frame(
28		#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
29		#' stringsAsFactors = FALSE
30		#' )
31		#' )
32		variable_types <- function(data, columns = NULL) {
33	9x	UseMethod("variable_types")
34		}
35
36		#' @export
37		variable_types.default <- function(data, columns = NULL) {
38	9x	checkmate::assert_character(columns, null.ok = TRUE, any.missing = FALSE)
39
40	9x	res <- if (is.null(columns)) {
41	!	vapply(
42	!	data,
43	!	function(x) class(x)[[1]],
44	!	character(1),
45	!	USE.NAMES = FALSE
46		)
47	9x	} else if (checkmate::test_character(columns, any.missing = FALSE)) {
48	9x	stopifnot(all(columns %in% names(data) \| vapply(columns, identical, logical(1L), "")))
49	9x	vapply(
50	9x	columns,
51	9x	function(x) ifelse(x == "", "", class(data[[x]])[[1]]),
52	9x	character(1),
53	9x	USE.NAMES = FALSE
54		)
55		} else {
56	!	character(0)
57		}
58
59	9x	return(res)
60		}
61
62		#' @export
63		variable_types.data.frame <- function(data, columns = NULL) { # nolint: object_name_linter.
64	9x	variable_types.default(data, columns)
65		}
66
67		#' @export
68		variable_types.DataTable <- function(data, columns = NULL) {
69	!	variable_types.default(data, columns)
70		}
71
72		#' @export
73		variable_types.DFrame <- function(data, columns = NULL) {
74	!	variable_types.default(data, columns)
75		}
76
77		#' @export
78		variable_types.matrix <- function(data, columns = NULL) {
79	!	checkmate::assert_character(columns, null.ok = TRUE, any.missing = FALSE)
80
81	!	res <- if (is.null(columns)) {
82	!	apply(
83	!	data,
84	!	2,
85	!	function(x) class(x)[1]
86		)
87	!	} else if (checkmate::test_character(columns, any.missing = FALSE)) {
88	!	stopifnot(
89	!	all(
90	!	columns %in% colnames(data) \|
91	!	vapply(columns, identical, logical(1L), "")
92		)
93		)
94	!	vapply(
95	!	columns,
96	!	function(x) ifelse(x == "", "", class(data[, x])[1]),
97	!	character(1),
98	!	USE.NAMES = FALSE
99		)
100		} else {
101	!	character(0)
102		}
103
104	!	return(res)
105		}

1		#' Initialize `FilteredData`
2		#'
3		#' Initialize `FilteredData`
4		#' @param x (named `list` or `TealData`) In case of `TealData` see [teal.data::teal_data()].
5		#' If the list is provided, it should contain `list`(s) containing following fields:
6		#' - `dataset` data object object supported by [`FilteredDataset`].
7		#' - `metatada` (optional) additional metadata attached to the `dataset`.
8		#' - `keys` (optional) primary keys.
9		#' - `datalabel` (optional) label describing the `dataset`.
10		#' - `parent` (optional) which `dataset` is a parent of this one.
11		#' @param join_keys (`JoinKeys`) see [teal.data::join_keys()].
12		#' @param code (`CodeClass`) see [`teal.data::CodeClass`].
13		#' @param check (`logical(1)`) whether data has been check against reproducibility.
14		#' @examples
15		#' library(shiny)
16		#' datasets <- teal.slice::init_filtered_data(
17		#' x = list(
18		#' iris = list(dataset = iris),
19		#' mtcars = list(dataset = mtcars, metadata = list(type = "training"))
20		#' )
21		#' )
22		#' @export
23		init_filtered_data <- function(x, join_keys, code, check) {
24	16x	UseMethod("init_filtered_data")
25		}
26
27		#' @keywords internal
28		#' @export
29		init_filtered_data.TealData <- function(x, # nolint
30		join_keys = x$get_join_keys(),
31		code = x$get_code_class(),
32		check = x$get_check()) {
33	2x	data_objects <- lapply(
34	2x	x$get_datanames(),
35	2x	function(dataname) {
36	3x	dataset <- x$get_dataset(dataname)
37	3x	list(
38	3x	dataset = dataset$get_raw_data(),
39	3x	metadata = dataset$get_metadata(),
40	3x	label = dataset$get_dataset_label()
41		)
42		}
43		)
44	2x	names(data_objects) <- x$get_datanames()
45
46	2x	init_filtered_data(
47	2x	x = data_objects,
48	2x	join_keys = join_keys,
49	2x	code = code,
50	2x	check = check
51		)
52		}
53
54		#' @keywords internal
55		#' @export
56		init_filtered_data.default <- function(x, join_keys = teal.data::join_keys(), code = NULL, check = FALSE) { # nolint
57	14x	checkmate::assert_list(x, any.missing = FALSE, names = "unique")
58	13x	mapply(validate_dataset_args, x, names(x))
59	13x	checkmate::assert_class(code, "CodeClass", null.ok = TRUE)
60	12x	checkmate::assert_class(join_keys, "JoinKeys")
61	11x	checkmate::assert_flag(check)
62	10x	FilteredData$new(x, join_keys = join_keys, code = code, check = check)
63		}
64
65		#' Validate dataset arguments
66		#'
67		#' Validate dataset arguments
68		#' @param dataset_args (`list`)\cr
69		#' containing the arguments except (`dataname`)
70		#' needed by `init_filtered_dataset`
71		#' @param dataname (`character(1)`)\cr
72		#' the name of the `dataset` to be added to this object
73		#' @keywords internal
74		#' @return (`NULL` or raises an error)
75		validate_dataset_args <- function(dataset_args, dataname) {
76	118x	check_simple_name(dataname)
77	118x	checkmate::assert_list(dataset_args, names = "unique")
78
79	118x	allowed_names <- c("dataset", "label", "metadata")
80
81	118x	checkmate::assert_subset(names(dataset_args), choices = allowed_names)
82	118x	checkmate::assert_multi_class(dataset_args[["dataset"]], classes = c("data.frame", "MultiAssayExperiment"))
83	117x	teal.data::validate_metadata(dataset_args[["metadata"]])
84	117x	checkmate::assert_character(dataset_args[["label"]], null.ok = TRUE, min.len = 0, max.len = 1)
85		}
86
87		#' Evaluate expression with meaningful message
88		#'
89		#' Method created for the `FilteredData` to execute filter call with
90		#' meaningful message. After evaluation used environment should contain
91		#' all necessary bindings.
92		#' @param expr (`language`)
93		#' @param env (`environment`) where expression is evaluated.
94		#' @return invisible `NULL`.
95		#' @keywords internal
96		eval_expr_with_msg <- function(expr, env) {
97	26x	lapply(
98	26x	expr,
99	26x	function(x) {
100	15x	tryCatch(
101	15x	eval(x, envir = env),
102	15x	error = function(e) {
103	!	stop(
104	!	sprintf(
105	!	"Call execution failed:\n - call:\n %s\n - message:\n %s ",
106	!	deparse1(x, collapse = "\n"), e
107		)
108		)
109		}
110		)
111	15x	return(invisible(NULL))
112		}
113		)
114		}
115
116
117		#' Toggle button properties.
118		#'
119		#' Switch between different icons or titles on a button.
120		#'
121		#' Wrapper functions that use `shinyjs::runjs` to change button properties in response to events,
122		#' typically clicking those very buttons.
123		#' `shiny`'s `actionButton` and `actionLink` create `<a>` tags,
124		#' which may contain a child `<i>` tag that specifies an icon to be displayed.
125		#' `toggle_icon` calls the `toggleClass` (when `one_way = FALSE`) or
126		#' `removeClass` and `addClass` methods (when `one_way = TRUE`) to change icons.
127		#' `toggle_title` calls the `attr` method to modify the `Title` attribute of the button.
128		#'
129		#' @param input_id `character(1)` (name-spaced) id of the button
130		#' @param icons,titles `character(2)` vector specifying values between which to toggle
131		#' @param one_way `logical(1)` flag specifying whether to keep toggling;
132		#' if TRUE, the target will be changed
133		#' from the first element of `icons`/`titles` to the second
134		#'
135		#' @return Invisible NULL.
136		#'
137		#' @name toggle_button
138		#'
139		#' @examples
140		#' library(shiny)
141		#'
142		#' ui <- fluidPage(
143		#' shinyjs::useShinyjs(),
144		#' actionButton("hide_content", label = "hide", icon = icon("xmark")),
145		#' actionButton("show_content", label = "show", icon = icon("check")),
146		#' actionButton("toggle_content", label = "toggle", icon = icon("angle-down")),
147		#' br(),
148		#' div(
149		#' id = "content",
150		#' verbatimTextOutput("printout")
151		#' )
152		#' )
153		#'
154		#' server <- function(input, output, session) {
155		#' observeEvent(input$hide_content,
156		#' {
157		#' shinyjs::hide("content")
158		#' toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE)
159		#' },
160		#' ignoreInit = TRUE
161		#' )
162		#'
163		#' observeEvent(input$show_content,
164		#' {
165		#' shinyjs::show("content")
166		#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE)
167		#' },
168		#' ignoreInit = TRUE
169		#' )
170		#'
171		#' observeEvent(input$toggle_content,
172		#' {
173		#' shinyjs::toggle("content")
174		#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"))
175		#' },
176		#' ignoreInit = TRUE
177		#' )
178		#'
179		#' output$printout <- renderPrint({
180		#' head(faithful, 10)
181		#' })
182		#' }
183		#' if (interactive()) {
184		#' shinyApp(ui, server)
185		#' }
186		#'
187		#' @rdname toggle_button
188		#' @keywords internal
189		toggle_icon <- function(input_id, icons, one_way = FALSE) {
190	3x	checkmate::assert_string(input_id)
191	3x	checkmate::assert_character(icons, len = 2L)
192	3x	checkmate::assert_flag(one_way)
193
194	3x	expr <-
195	3x	if (one_way) {
196	3x	sprintf(
197	3x	"$('#%s i').removeClass('%s').addClass('%s');",
198	3x	input_id, icons[1], icons[2]
199		)
200		} else {
201	!	sprintf("$('#%s i').toggleClass('%s');", input_id, paste(icons, collapse = " "))
202		}
203
204	3x	shinyjs::runjs(expr)
205
206	3x	invisible(NULL)
207		}
208
209		#' @rdname toggle_button
210		#' @keywords internal
211		toggle_title <- function(input_id, titles, one_way = FALSE) {
212	3x	checkmate::assert_string(input_id)
213	3x	checkmate::assert_character(titles, len = 2L)
214	3x	checkmate::assert_flag(one_way)
215
216	3x	expr <-
217	3x	if (one_way) {
218	3x	sprintf(
219	3x	"$('a#%s').attr('title', '%s');",
220	3x	input_id, titles[2]
221		)
222		} else {
223	!	sprintf(
224	!	paste0(
225	!	"var button_id = 'a#%1$s';",
226	!	"var curr = $(button_id).attr('title');",
227	!	"if (curr == '%2$s') { $(button_id).attr('title', '%3$s');",
228	!	"} else { $(button_id).attr('title', '%2$s');",
229		"}"
230		),
231	!	input_id, titles[1], titles[2]
232		)
233		}
234
235	3x	shinyjs::runjs(expr)
236
237	3x	invisible(NULL)
238		}
239
240		#' Topological graph sort
241		#'
242		#' Graph is a list which for each node contains a vector of child nodes
243		#' in the returned list, parents appear before their children.
244		#'
245		#' Implementation of `Kahn` algorithm with a modification to maintain the order of input elements.
246		#'
247		#' @param graph (named `list`) list with node vector elements
248		#' @keywords internal
249		#'
250		#' @examples
251		#' teal.slice:::topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
252		#' teal.slice:::topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
253		#' teal.slice:::topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
254		topological_sort <- function(graph) {
255		# compute in-degrees
256	65x	in_degrees <- list()
257	65x	for (node in names(graph)) {
258	101x	in_degrees[[node]] <- 0
259	101x	for (to_edge in graph[[node]]) {
260	9x	in_degrees[[to_edge]] <- 0
261		}
262		}
263
264	65x	for (node in graph) {
265	101x	for (to_edge in node) {
266	9x	in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1
267		}
268		}
269
270		# sort
271	65x	visited <- 0
272	65x	sorted <- list()
273	65x	zero_in <- list()
274	65x	for (node in names(in_degrees)) {
275	92x	if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node)
276		}
277	65x	zero_in <- rev(zero_in)
278
279	65x	while (length(zero_in) != 0) {
280	98x	visited <- visited + 1
281	98x	sorted <- c(zero_in[[1]], sorted)
282	98x	for (edge_to in graph[[zero_in[[1]]]]) {
283	6x	in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1
284	6x	if (in_degrees[[edge_to]] == 0) {
285	6x	zero_in <- append(zero_in, edge_to, 1)
286		}
287		}
288	98x	zero_in[[1]] <- NULL
289		}
290
291	65x	if (visited != length(in_degrees)) {
292	1x	stop(
293	1x	"Graph is not a directed acyclic graph. Cycles involving nodes: ",
294	1x	paste0(setdiff(names(in_degrees), sorted), collapse = " ")
295		)
296		} else {
297	64x	return(sorted)
298		}
299		}

1		#' Combine calls by operator
2		#'
3		#' Combine list of calls by specific operator
4		#'
5		#' @param calls (`list` of calls)\cr
6		#' list containing calls to be combined by `operator`;
7		#' if empty, NULL is returned
8		#' @param operator (`character(1)`)\cr
9		#' name/symbol of the operator passed as character string
10		#'
11		#' @return call or NULL, if `calls` is an empty list
12		#'
13		#' @examples
14		#' calls <- list(
15		#' quote(SEX == "F"), # subsetting on factor
16		#' quote(AGE >= 20 & AGE <= 50), # subsetting on range
17		#' quote(!SURV) # subsetting on logical
18		#' )
19		#' teal.slice:::calls_combine_by(calls, "&")
20		#'
21		#' @return a combined `call`
22		#' @keywords internal
23		calls_combine_by <- function(calls, operator) {
24	46x	checkmate::assert_list(calls)
25	44x	if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
26	45x	checkmate::assert_string(operator)
27
28	43x	calls <- Filter(x = calls, f = Negate(is.null))
29
30	43x	Reduce(
31	43x	x = calls,
32	43x	f = function(x, y) call(operator, x, y)
33		)
34		}

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

1		#' Ensure the ellipsis, ..., in method arguments are empty
2		#'
3		#' Ellipsis, ..., are needed as part of method arguments to allow for its arguments to be different from its generic's
4		#' arguments and for this to pass check(). Hence, ..., should always be empty. This function will check for this
5		#' condition.
6		#'
7		#' @param ... it should literally just be ...
8		#' @param stop TRUE to raise an error; FALSE will output warning message
9		#' @param allowed_args character vector naming arguments that are allowed in the \code{...}.
10		#' to allow for unnamed arguments, let "" be one of the elements in this character vector.
11		#'
12		#' @return \code{NULL} if ... is empty
13		#'
14		#' @keywords internal
15		#'
16		#' @examples
17		#' method.class <- function(a, b, c, ...) {
18		#' check_ellipsis(...)
19		#' }
20		#' method.class <- function(a, b, c, ...) {
21		#' check_ellipsis(..., allowed_args = c("y", "z"))
22		#' }
23		check_ellipsis <- function(..., stop = FALSE, allowed_args = character(0)) {
24	18x	if (!missing(...)) {
25	16x	checkmate::assert_flag(stop)
26	16x	checkmate::assert_character(allowed_args, min.len = 0, null.ok = TRUE, any.missing = FALSE)
27	16x	args <- list(...)
28	16x	arg_names <- names(args)
29	16x	if (is.null(arg_names)) {
30	4x	arg_names <- rep("", length(args))
31		}
32	16x	extra_args <- arg_names[!is.element(arg_names, allowed_args)]
33	16x	if (length(extra_args) == 0) {
34	4x	return(invisible(NULL))
35		}
36	12x	message <- paste(length(extra_args), "total unused argument(s).")
37
38	12x	named_extra_args <- extra_args[!vapply(extra_args, identical, logical(1), "")]
39	12x	if (length(named_extra_args) > 0) {
40	9x	message <- paste0(
41	9x	message,
42		" ",
43	9x	length(named_extra_args),
44	9x	" with name(s): ",
45	9x	paste(named_extra_args, collapse = ", "),
46		"."
47		)
48		}
49	12x	if (stop) {
50	8x	stop(message)
51		} else {
52	4x	warning(message)
53		}
54		}
55		}
56
57		#' Whether the variable name is good to use within Show R Code
58		#'
59		#' Spaces are problematic because the variables must be escaped with backticks.
60		#' Also, they should not start with a number as R may silently make it valid by changing it.
61		#' Therefore, we only allow alphanumeric characters with underscores.
62		#' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters.
63		#'
64		#' @md
65		#'
66		#' @param name `character, single or vector` name to check
67		#' @keywords internal
68		#'
69		#' @examples
70		#' teal.slice:::check_simple_name("aas2df")
71		#' teal.slice:::check_simple_name("ADSL")
72		#' teal.slice:::check_simple_name("ADSLmodified")
73		#' teal.slice:::check_simple_name("ADSL_modified")
74		#' teal.slice:::check_simple_name("ADSL_2")
75		#' teal.slice:::check_simple_name("a1")
76		#' # the following fail
77		#' if (interactive()) {
78		#' teal.slice:::check_simple_name("1a")
79		#' teal.slice:::check_simple_name("ADSL.modified")
80		#' teal.slice:::check_simple_name("a1...")
81		#' }
82		check_simple_name <- function(name) {
83	380x	checkmate::assert_character(name, min.len = 1, any.missing = FALSE)
84	378x	if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
85	5x	stop(
86	5x	"name '",
87	5x	name,
88	5x	"' must only contain alphanumeric characters (with underscores)",
89	5x	" and the first character must be an alphabetic character"
90		)
91		}
92		}
93
94		#' Resolve the expected bootstrap theme
95		#' @keywords internal
96		get_teal_bs_theme <- function() {
97	2x	bs_theme <- getOption("teal.bs_theme")
98	2x	if (is.null(bs_theme)) {
99	1x	NULL
100	1x	} else if (!inherits(bs_theme, "bs_theme")) {
101	!	warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
102	!	NULL
103		} else {
104	1x	bs_theme
105		}
106		}
107
108		#' Include `JS` files from `/inst/js/` package directory to application header
109		#'
110		#' `system.file` should not be used to access files in other packages, it does
111		#' not work with `devtools`. Therefore, we redefine this method in each package
112		#' as needed. Thus, we do not export this method
113		#'
114		#' @param pattern (`character`) pattern of files to be included, passed to `system.file`
115		#' @param except (`character`) vector of basename filenames to be excluded
116		#'
117		#' @return HTML code that includes `JS` files
118		#' @keywords internal
119		include_js_files <- function(pattern) {
120	12x	checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE)
121	12x	js_files <- list.files(
122	12x	system.file("js", package = "teal.slice", mustWork = TRUE),
123	12x	pattern = pattern,
124	12x	full.names = TRUE
125		)
126	12x	return(singleton(lapply(js_files, includeScript)))
127		}
128
129		#' This function takes a vector of values and returns a `c` call. If the vector
130		#' has only one element, the element is returned directly.
131		#'
132		#' @param choices A vector of values.
133		#'
134		#' @return A `c` call.
135		#'
136		#' @examples
137		#' teal.slice:::make_c_call(1:3)
138		#' # [1] 1 2 3
139		#'
140		#' teal.slice:::make_c_call(1)
141		#' # [1] 1
142		#' @keywords internal
143		make_c_call <- function(choices) {
144	53x	if (length(choices) > 1) {
145	26x	do.call("call", append(list("c"), choices))
146		} else {
147	27x	choices
148		}
149		}

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

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

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

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

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

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

1		#' Store teal_slices object to a file
2		#'
3		#' This function takes a `teal_slices` object and saves it to a file in `JSON` format.
4		#' The `teal_slices` object contains information about filter states and can be used to
5		#' create, modify, and delete filter states. The saved file can be later loaded using
6		#' the `slices_restore` function.
7		#'
8		#' @param tss (`teal_slices`) object to be stored.
9		#' @param file (`character(1)`) The file path where `teal_slices` object will be saved.
10		#' The file extension should be `".json"`.
11		#'
12		#' @return `NULL`, invisibly.
13		#'
14		#' @examples
15		#' # Create a teal_slices object
16		#' tss <- teal_slices(
17		#' teal_slice(dataname = "data", varname = "var"),
18		#' teal_slice(dataname = "data", expr = "x > 0", id = "positive_x", title = "Positive x")
19		#' )
20		#'
21		#' if (interactive()) {
22		#' # Store the teal_slices object to a file
23		#' slices_store(tss, "path/to/file.json")
24		#' }
25		#'
26		#' @export
27		slices_store <- function(tss, file) {
28	!	checkmate::assert_class(tss, "teal_slices")
29	!	checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json")
30
31	!	cat(format(tss, trim_lines = FALSE), "\n", file = file)
32		}
33
34		#' Restore teal_slices object from a file
35		#'
36		#' This function takes a file path to a `JSON` file containing a `teal_slices` object
37		#' and restores it to its original form. The restored `teal_slices` object can be used
38		#' to access filter states and their corresponding attributes.
39		#'
40		#' @param file Path to file where `teal_slices` is stored. Must have a `.json` extension and read access.
41		#'
42		#' @return A `teal_slices` object restored from the file.
43		#'
44		#' @examples
45		#' if (interactive()) {
46		#' # Restore a teal_slices object from a file
47		#' tss_restored <- slices_restore("path/to/file.json")
48		#' }
49		#' @export
50		slices_restore <- function(file) {
51	!	checkmate::assert_file_exists(file, access = "r", extension = "json")
52
53	!	tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE)
54
55	!	tss_elements <- lapply(tss_json$slices, as.teal_slice)
56
57	!	do.call(teal_slices, c(tss_elements, tss_json$attributes))
58		}

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