teal.slice coverage - 65.92%

Files
Source

# FilteredData ------

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

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

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

      self$set_available_teal_slices(x = reactive(NULL))

      invisible(self)
    },

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

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

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

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

    # datasets methods ----

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

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

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

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

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

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

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

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

      invisible(self)
    },

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

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

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

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

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

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

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

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

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

      invisible(NULL)
    },

    #' @description
    #' Removes one or more `FilterState` from a `FilteredData` object.
    #'
    #' @param state (`teal_slices`)
    #'   specifying `FilterState` objects to remove;
    #'   `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored.
    #'
    #' @return `NULL`, invisibly.
    #'
    remove_filter_state = function(state) {
      isolate({
        checkmate::assert_class(state, "teal_slices")
        datanames <- unique(vapply(state, "[[", character(1L), "dataname"))
        checkmate::assert_subset(datanames, self$datanames())

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

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

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

      invisible(NULL)
    },

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

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

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

      invisible(NULL)
    },


    # shiny modules -----

    #' @description
    #' top-level `shiny` module for the filter panel in the `teal` app.
    #' Contains 1) filter overview panel, 2) filter active panel, and 3) add filters panel.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `shiny.tag`
    ui_filter_panel = function(id) {
      ns <- NS(id)
      tags$div(
        id = ns(NULL), # used for hiding / showing
        include_css_files(pattern = "filter-panel"),
        self$ui_overview(ns("overview")),
        self$ui_active(ns("active")),
        if (private$allow_add) {
          self$ui_add(ns("add"))
        }
      )
    },

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

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

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

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

    #' @description
    #' Server module responsible for displaying active filters.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `shiny.tag`
    ui_active = function(id) {
      ns <- NS(id)
      tags$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"
          )
        ),
        tags$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(
          tags$div(
            id = ns("filters_active_count"),
            textOutput(ns("teal_filters_count"))
          )
        )
      )
    },

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

        private$srv_available_filters("available_filters")

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

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

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

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

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

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

    #' @description
    #' Server module responsible for displaying drop-downs with variables to add a filter.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `shiny.tag`
    ui_add = function(id) {
      ns <- NS(id)
      tags$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"
            )
          )
        ),
        tags$div(
          id = ns("filter_add_vars_contents"),
          tagList(
            lapply(
              self$datanames(),
              function(dataname) {
                fdataset <- private$get_filtered_dataset(dataname)
                tags$span(id = ns(dataname), fdataset$ui_add(ns(dataname)))
              }
            )
          )
        )
      )
    },

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

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

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

    #' @description
    #' Creates the UI definition for the module showing counts for each dataset
    #' contrasting the filtered to the full unfiltered dataset.
    #'
    #' Per dataset, it displays
    #' the number of rows/observations in each dataset,
    #' the number of unique subjects.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    ui_overview = function(id) {
      ns <- NS(id)
      tags$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"
            )
          )
        ),
        tags$div(
          id = ns("filters_overview_contents"),
          tags$div(
            class = "teal_active_summary_filter_panel",
            tableOutput(ns("table"))
          )
        )
      )
    },

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

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

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

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

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

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


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

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

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

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

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

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

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

    # activate/deactivate filter panel
    filter_panel_active = TRUE,

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

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

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

    # private methods ----

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

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

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

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

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

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

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

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

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

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

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

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

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

# RangeFilterState ------

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

  # public methods ----
  public = list(

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

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

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

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

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

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

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

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

    # private methods ----

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

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

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

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

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

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

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

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

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

    # shiny modules ----

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

        # this observer is needed in the situation when private$teal_slice$keep_inf has been
        # changed directly by the api - then it's needed to rerender UI element
        # to show relevant values
        private$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)
      })
    }
  )
)

# MAEFilteredDataset ------

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

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

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

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

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

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

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

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

        invisible(NULL)
      })
    },

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

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

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


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

      invisible(NULL)
    },

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

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

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

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

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

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

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

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

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

  formal_args <- as.list(environment())

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

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

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

  ans
}

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

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

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

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

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

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

  x[c(formal_args, extra_args)]
}


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

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

  jsonify(x_list, trim_lines)
}

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


# format utils -----

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

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

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

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

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

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

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

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

# DataframeFilteredDataset ------

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

  # public fields ----
  public = list(

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

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

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

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

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

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

      invisible(self)
    },

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

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

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

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

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

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

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #' @return `NULL`, invisibly.
    #'
    set_filter_state = function(state) {
      isolate({
        logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
        checkmate::assert_class(state, "teal_slices")
        lapply(state, function(slice) {
          checkmate::assert_true(slice$dataname == private$dataname)
        })
        private$get_filter_states()[[1L]]$set_filter_state(state = state)
        invisible(NULL)
      })
    },

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

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

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

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

      invisible(NULL)
    },

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

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

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

# DatetimeFilterState ------

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

  # public methods ----

  public = list(

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

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

      invisible(self)
    },

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

  # private members ----

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

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

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

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

      values
    },

    # shiny modules ----

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

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

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

    # @description
    # Server module
    # @param id (`character(1)`) `shiny` module instance id.
    # @return `NULL`.
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_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)
            tags$div(
              tags$div(icon("clock"), vals[1]),
              tags$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]


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

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

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

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