teal.slice coverage - 86.80%

Files
Source

# DatetimeFilterState ------

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

  # public methods ----

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

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

      invisible(self)
    },

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

  # private members ----

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

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

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

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

      values
    },

    # shiny modules ----

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

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

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

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

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


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

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

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

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

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

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

          private$keep_na_srv("keep_na")

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

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

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

          NULL
        }
      )
    },

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

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

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

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

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

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

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

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


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


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

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


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

  all_attributes <- lapply(x, attributes)
  all_attributes <- coalesce_r(all_attributes)
  all_attributes <- all_attributes[names(all_attributes) != "class"]
  slices <- unlist(x, recursive = FALSE)
  do.call(
    teal_slices,
    c(
      slices,
      all_attributes
    )
  )
}


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

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

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

  jsonify(slices_list, trim_lines)
}

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


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

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

# RangeFilterState ------

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

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

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

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

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

        private$plot_data <- list(
          type = "histogram",
          nbinsx = 50,
          x = Filter(Negate(is.na), Filter(is.finite, private$x)),
          color = I(fetch_bs_color("secondary")),
          alpha = 0.2,
          bingroup = 1,
          showlegend = FALSE,
          hoverinfo = "none"
        )
        private$plot_mask <- list(list(
          type = "rect", fillcolor = rgb(1, 1, 1, .65), line = list(width = 0),
          x0 = -0.5, x1 = 1.5, y0 = -0.5, y1 = 1.5, xref = "paper", yref = "paper"
        ))
        private$plot_layout <- reactive({
          shapes <- private$get_shape_properties(private$get_selected())
          list(
            barmode = "overlay",
            xaxis = list(
              range = private$get_choices() * c(0.995, 1.005),
              rangeslider = list(thickness = 0),
              showticklabels = TRUE,
              ticks = "outside",
              ticklen = 1.5,
              tickmode = "auto",
              nticks = 10
            ),
            yaxis = list(showgrid = FALSE, showticklabels = FALSE),
            margin = list(b = 17, l = 0, r = 0, t = 0, autoexpand = FALSE),
            plot_bgcolor = "#FFFFFF00",
            paper_bgcolor = "#FFFFFF00",
            shapes = shapes,
            autosize = TRUE
          )
        })
        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)]
      new_choices <- if (is.null(choices)) {
        range(x)
      } else {
        choices_adjusted <- c(max(choices[1L], min(x)), min(choices[2L], max(x)))
        if (choices_adjusted[1L] > choices_adjusted[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_adjusted <- range(x)
        }
        choices_adjusted
      }

      private$set_is_choice_limited(private$x, new_choices)
      valid_range_index <- (private$x >= new_choices[1L] & private$x <= new_choices[2L])
      private$x <- private$x[valid_range_index | !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)) {
        new_choices <- x_range
      } else {
        x_pretty <- pretty(x_range, 100L)
        new_choices <- range(x_pretty)
        private$numeric_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10)
      }
      private$teal_slice$choices <- new_choices
      # Only throw warning if pretty choices are different
      if (!is.null(choices) && any(choices != new_choices)) {
        warning(sprintf(
          "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",
          private$get_varname(), private$get_dataname()
        ))
      }

      invisible(NULL)
    },

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

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

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

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

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

    # shiny modules ----

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

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

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

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

          trigger_event_data <- reactiveVal(FALSE)

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

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

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

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

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

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

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


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

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

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

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

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

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

          NULL
        }
      )
    },

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

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

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

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

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

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

        invisible(NULL)
      })
    }
  )
)

# FilteredDataset abstract --------

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

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

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

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


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

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

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

    # managing filter states -----

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

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

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

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

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

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

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

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

    # modules ------
    #' @description
    #' `shiny` module containing active filters for a dataset, along with a title and a remove button.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @return `shiny.tag`
    ui_active = function(id) {
      ns <- NS(id)
      uiOutput(ns("container"))
    },
    #' @description
    #' Server module for a dataset active filters.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `NULL`.
    srv_active = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          dataname <- self$get_dataname()
          logger::log_debug("FilteredDataset$srv_active initializing, dataname: { dataname }")

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

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

          output$container <- renderUI({
            if (is_displayed()) {
              isolate({
                tags$span(
                  id = session$ns(id),
                  class = "teal-slice",
                  include_css_files("filter-panel"),
                  include_js_files(pattern = "icons"),
                  bslib::accordion(
                    id = session$ns("dataset_filter_accordion"),
                    class = "teal-slice-dataset-filter",
                    bslib::accordion_panel(
                      tags$span(dataname, uiOutput(session$ns("active_filter_badge"), inline = TRUE)),
                      value = dataname,
                      style = "padding: 0; margin: 0;",
                      bslib::page_fluid(
                        id = session$ns("whole_ui"),
                        style = "margin: 0; padding: 0;",
                        div(
                          id = session$ns("filter_util_icons"),
                          class = "teal-slice filter-util-icons",
                          tags$a(
                            class = "teal-slice filter-icon",
                            tags$i(
                              id = session$ns("add_filter_icon"),
                              class = "fa fa-plus",
                              title = "fold/expand transform panel",
                              onclick = sprintf(
                                "togglePanelItems(this, '%s', 'fa-plus', 'fa-minus');
                                if ($(this).hasClass('fa-minus')) {
                                  $('#%s .accordion-button.collapsed').click();
                                }",
                                session$ns("add_panel"),
                                session$ns("dataset_filter_accordion")
                              )
                            )
                          ),
                          uiOutput(session$ns("filter_util_remove_icons"))
                        ),
                        bslib::page_fluid(
                          style = "padding: 0px; margin: 0;",
                          tags$div(
                            id = session$ns("add_panel"),
                            class = "add-panel",
                            style = "display: none;",
                            self$ui_add(session$ns(private$dataname))
                          )
                        ),
                        tags$div(
                          id = session$ns("filter_count_ui"),
                          style = "display: none;",
                          tagList(
                            textOutput(session$ns("filter_count"))
                          )
                        ),
                        tags$div(
                          # id needed to insert and remove UI to filter single variable as needed
                          # it is currently also used by the above module to entirely hide this panel
                          id = session$ns("filters"),
                          class = "parent-hideable-list-group",
                          tagList(
                            lapply(
                              names(private$get_filter_states()),
                              function(x) {
                                tagList(private$get_filter_states()[[x]]$ui_active(id = session$ns(x)))
                              }
                            )
                          )
                        )
                      )
                    )
                  ),
                  # We need to dynamically move filter_util_icons as they cannot be created in header without
                  # preventing the click event to propagate and collapse/show the accordion.
                  tags$script(
                    HTML(
                      sprintf(
                        "$(document).ready(() => $('#%s').appendTo('#%s > .accordion-item > .accordion-header'))",
                        session$ns("filter_util_icons"),
                        session$ns("dataset_filter_accordion")
                      )
                    )
                  )
                )
              })
            }
          })

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

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

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

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

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

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

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

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

          self$srv_add(private$dataname)

          NULL
        }
      )
    },

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

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

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

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

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

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

# LogicalFilterState ------

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

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

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

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

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

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

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

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

    # shiny modules ----

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

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

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

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

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

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

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

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

          private$keep_na_srv("keep_na")

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

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

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

          NULL
        }
      )
    },

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

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

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

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

  do.call(FilterState$new, args)
}

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

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

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

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

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

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

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

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

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

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

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


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


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

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

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

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

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

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

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

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

  paste0(color_specification[color], alpha)
}

# DateFilterState ------

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

  # public methods ----

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

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

      invisible(self)
    },

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

  # private methods ----

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

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

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

      values
    },

    # shiny modules ----

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

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

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

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

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

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


          private$keep_na_srv("keep_na")

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

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

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

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

          NULL
        }
      )
    },

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

#' 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 <- withReactiveDomain(NULL, 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 <- withReactiveDomain(NULL, do.call(reactiveValues, args))
    class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
  } else {
    stop("Must provide either `expr` or `varname`.")
  }

  ans
}

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

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

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

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

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

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

  x[c(formal_args, extra_args)]
}


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

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

  jsonify(x_list, trim_lines)
}

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


# format utils -----

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

# FilteredData ------

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

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

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

      self$set_available_teal_slices(x = reactive(NULL))

      invisible(self)
    },

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

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

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

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

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

    # datasets methods ----

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

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

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

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

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

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

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

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

      invisible(self)
    },

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

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

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

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

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

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

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

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

        invisible(NULL)
      })

      invisible(NULL)
    },

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

      invisible(NULL)
    },

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


    # shiny modules -----

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

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

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

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

        NULL
      })
    },

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

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

        private$srv_available_filters("available_filters")

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

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

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

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

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

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

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

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

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

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

        NULL
      })
    },

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

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

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

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

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

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


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

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

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

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

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

          NULL
        }
      )
    }
  ),

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

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

    # activate/deactivate filter panel
    filter_panel_active = TRUE,

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

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

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

    # observers and inputs list
    session_bindings = list(),

    # private methods ----

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

  shinyjs::runjs(expr)

  invisible(NULL)
}

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

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

  shinyjs::runjs(expr)

  invisible(NULL)
}

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

# ChoicesFilterState ------

#' Drop unused factor levels while preserving label attribute
#'
#' @description
#' Helper function to drop unused levels from a factor variable while preserving
#' the `label` attribute. The base R `droplevels()` function strips all attributes
#' except `levels` and `class`, which causes the loss of variable labels that are
#' commonly used in clinical trial datasets.
#'
#' @param x (`factor`) A factor variable, potentially with a `label` attribute.
#'
#' @return The input factor with unused levels dropped and the `label` attribute preserved.
#'
#' @keywords internal
.drop_levels_keep_label <- function(x) {
  label_attr <- attr(x, "label", exact = TRUE)
  x <- droplevels(x)
  if (!is.null(label_attr)) {
    attr(x, "label") <- label_attr
  }
  x
}

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

  # public methods ----

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

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

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

    # private methods ----

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

    # shiny modules ----

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

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

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

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

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

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

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

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

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

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

          private$keep_na_srv("keep_na")

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

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

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

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

          NULL
        }
      )
    },

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

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

# DataframeFilteredDataset ------

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

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

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

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

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

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

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

      invisible(self)
    },

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

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

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

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

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

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

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

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

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

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

      invisible(NULL)
    },

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

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

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

# SEFilterStates ------

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

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

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

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

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

        invisible(NULL)
      })
    },

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

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

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

      tags$div(row_input, col_input)
    },

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

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

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

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

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

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

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

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

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

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

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


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

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

          NULL
        }
      )
    }
  )
)

# FilterStates ------

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

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

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

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

      invisible(self)
    },

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

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

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

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

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

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

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

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

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

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

      fs
    },

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

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

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

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

      invisible(NULL)
    },

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

    # shiny modules ----

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

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

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

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

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

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

          NULL
        }
      )
    },

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

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

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

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

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

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

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

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

    # private methods ----

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

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

    # state_list methods ----

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

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

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

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

      invisible(NULL)
    },

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

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

      invisible(NULL)
    },

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

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

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

        invisible(NULL)
      })
    },

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

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

  ns <- NS(inputId)

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

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

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

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

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

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

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

  invisible(NULL)
}

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

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


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

# FilterState ------

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

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

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

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

        private$state_history <- withReactiveDomain(NULL, reactiveVal(list()))

        invisible(self)
      })
    },

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

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

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

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

        invisible(self)
      })
    },


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

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

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

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

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

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

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

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

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

          private$state_history <- reactiveVal(list())

          NULL
        }
      )
    },

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

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

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

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

    # private methods ----

    # setters for state features ----

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

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

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

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

    # getters for state features ----

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

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

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

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

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

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

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

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

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

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

    # other ----

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

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

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

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

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

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

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

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

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

    # shiny modules -----

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

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

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

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

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

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

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

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

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

# MAEFilteredDataset ------

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

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

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

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

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

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

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

        invisible(NULL)
      })
    },

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

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

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

      invisible(NULL)
    },

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

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

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

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

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

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

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

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

# MAEFilterStates ------

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

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

      invisible(self)
    }
  ),

  # private fields ----

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

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

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

  invisible()
}

### GLOBAL VARIABLES ###

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


### END GLOBAL VARIABLES ###


### ENSURE CHECK PASSES

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


### END ENSURE CHECK PASSES

# DefaultFilteredDataset ----

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

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

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

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

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

    # shiny modules ----

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

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

# EmptyFilterState ------

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

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

      invisible(self)
    },

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

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


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

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

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

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

# DFFilterStates ------

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

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

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

# FilterPanelAPI ------

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

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

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

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

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

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

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

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

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

#' Set "`<choice>:<label>`" type of names
#'
#' @description
#'
#' This is often useful for as it marks up the drop-down boxes for [shiny::selectInput()].
#'
#' @details
#' If either `choices` or `labels` are factors, they are coerced to character.
#' Duplicated elements from `choices` get removed.
#'
#' @param choices (`character` or `numeric` or `logical`) vector
#' @param labels (`character`) vector containing labels to be applied to `choices`. If `NA` then
#' "Label Missing" will be used.
#' @param types vector containing the types of the columns.
#'
#' @return A named character vector.
#'
#' @keywords internal
#'
choices_labeled <- function(choices, labels, types = NULL) {
  checkmate::assert_character(choices)
  checkmate::assert_character(labels[!is.na(labels)], len = length(choices))
  checkmate::assert_character(types, len = length(choices), null.ok = TRUE)

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

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

  choices
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  datasets$remove_filter_state(filter)
  invisible(NULL)
}

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

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

# FilterStateExpr ------

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

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

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

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

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

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

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

    # public shiny modules ----

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

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

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

          NULL
        }
      )
    },

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

  # private members ----

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

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

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

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

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

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

# MatrixFilterStates ------

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

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

# This file contains helper functions used in unit tests.

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


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

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

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

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

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

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

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

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

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

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	663x	checkmate::assert_string(dataname)
125	656x	checkmate::assert_flag(fixed)
126	654x	checkmate::assert_flag(anchored)
127
128	652x	formal_args <- as.list(environment())
129
130	652x	if (!missing(expr) && !missing(varname)) {
131	1x	stop("Must provide either `expr` or `varname`.")
132	651x	} else if (!missing(expr)) {
133	37x	checkmate::assert_string(id)
134	34x	checkmate::assert_string(title)
135	31x	checkmate::assert_string(expr)
136
137	30x	formal_args$fixed <- TRUE
138	30x	ts_expr_args <- c("dataname", "id", "expr", "fixed", "anchored", "title")
139	30x	formal_args <- formal_args[ts_expr_args]
140	30x	ans <- withReactiveDomain(NULL, do.call(reactiveValues, c(formal_args, list(...))))
141	30x	class(ans) <- c("teal_slice_expr", "teal_slice", class(ans))
142	614x	} else if (!missing(varname)) {
143	613x	checkmate::assert_string(varname)
144	610x	checkmate::assert_multi_class(choices, .filterable_class, null.ok = TRUE)
145	609x	checkmate::assert_multi_class(selected, .filterable_class, null.ok = TRUE)
146	607x	checkmate::assert_flag(keep_na, null.ok = TRUE)
147	606x	checkmate::assert_flag(keep_inf, null.ok = TRUE)
148	605x	checkmate::assert_flag(multiple)
149
150	605x	ts_var_args <- c(
151	605x	"dataname", "varname", "id", "choices", "selected", "keep_na", "keep_inf",
152	605x	"fixed", "anchored", "multiple"
153		)
154	605x	formal_args <- formal_args[ts_var_args]
155	605x	args <- c(formal_args, list(...))
156	605x	args[c("choices", "selected")] <-
157	605x	lapply(args[c("choices", "selected")], function(x) if (is.factor(x)) as.character(x) else x)
158	605x	if (missing(id)) {
159	590x	args$id <- get_default_slice_id(args)
160		} else {
161	15x	checkmate::assert_string(id)
162		}
163	602x	ans <- withReactiveDomain(NULL, do.call(reactiveValues, args))
164	602x	class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
165		} else {
166	1x	stop("Must provide either `expr` or `varname`.")
167		}
168
169	632x	ans
170		}
171
172		#' `teal_slice` utility functions
173		#'
174		#' Helper functions for working with [`teal_slice`] object.
175		#' @param x (`teal.slice`)
176		#' @param show_all (`logical(1)`) indicating whether to show all fields. If set to `FALSE`,
177		#' only non-NULL elements will be printed.
178		#' @param trim_lines (`logical(1)`) indicating whether to trim lines when printing.
179		#' @param ... additional arguments passed to other functions.
180		#' @name teal_slice-utilities
181		#' @inherit teal_slice examples
182		#' @keywords internal
183
184		#' @rdname teal_slice-utilities
185		#' @export
186		#'
187		is.teal_slice <- function(x) { # nolint
188	4x	inherits(x, "teal_slice")
189		}
190
191		#' @rdname teal_slice-utilities
192		#' @export
193		#'
194		as.teal_slice <- function(x) { # nolint
195	2x	checkmate::assert_list(x, names = "named")
196	2x	do.call(teal_slice, x)
197		}
198
199		#' @rdname teal_slice-utilities
200		#' @export
201		#'
202		as.list.teal_slice <- function(x, ...) {
203	1823x	formal_args <- setdiff(names(formals(teal_slice)), "...")
204
205	1823x	x <- if (isRunning()) {
206	!	reactiveValuesToList(x)
207		} else {
208	1823x	isolate(reactiveValuesToList(x))
209		}
210
211	1823x	formal_args <- intersect(formal_args, names(x))
212	1823x	extra_args <- rev(setdiff(names(x), formal_args))
213
214	1823x	x[c(formal_args, extra_args)]
215		}
216
217
218		#' @rdname teal_slice-utilities
219		#' @export
220		#'
221		format.teal_slice <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
222	117x	checkmate::assert_flag(show_all)
223	93x	checkmate::assert_flag(trim_lines)
224
225	87x	x_list <- as.list(x)
226	48x	if (!show_all) x_list <- Filter(Negate(is.null), x_list)
227
228	87x	jsonify(x_list, trim_lines)
229		}
230
231		#' @rdname teal_slice-utilities
232		#' @export
233		#'
234		print.teal_slice <- function(x, ...) {
235	16x	cat(format(x, ...))
236	16x	invisible(x)
237		}
238
239
240		# format utils -----
241
242		#' Convert a list to a justified `JSON` string
243		#'
244		#' This function takes a list and converts it to a `JSON` string.
245		#' The resulting `JSON` string is then optionally justified to improve readability
246		#' and trimmed to easier fit in the console when printing.
247		#'
248		#' @param x (`list`), possibly recursive, obtained from `teal_slice` or `teal_slices`.
249		#' @param trim_lines (`logical(1)`) flag specifying whether to trim lines of the `JSON` string.
250		#' @return A `JSON` string representation of the input list.
251		#' @keywords internal
252		#'
253		jsonify <- function(x, trim_lines) {
254	133x	checkmate::assert_list(x)
255
256	133x	x_json <- to_json(x)
257	133x	x_json_justified <- justify_json(x_json)
258	123x	if (trim_lines) x_json_justified <- trim_lines_json(x_json_justified)
259	133x	paste(x_json_justified, collapse = "\n")
260		}
261
262		#' Converts a list to a `JSON` string
263		#'
264		#' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string.
265		#' Ensures proper unboxing of list elements.
266		#' This function is used by the `format` methods for `teal_slice` and `teal_slices`.
267		#' @param x (`list`) possibly recursive, obtained from `teal_slice` or `teal_slices`.
268		#' @return A `JSON` string.
269		#
270		#' @param x (`list`) representation of `teal_slices` object.
271		#' @keywords internal
272		#'
273		to_json <- function(x) {
274	133x	no_unbox <- function(x) {
275	2415x	vars <- c("selected", "choices")
276	2415x	if (is.list(x)) {
277	391x	for (var in vars) {
278	307x	if (!is.null(x[[var]])) x[[var]] <- I(format_time(x[[var]]))
279		}
280	391x	lapply(x, no_unbox)
281		} else {
282	2024x	x
283		}
284		}
285
286	133x	jsonlite::toJSON(no_unbox(x), pretty = TRUE, auto_unbox = TRUE, digits = 16, null = "null")
287		}
288
289		#' Format `POSIXt` for storage
290		#'
291		#' Convert `POSIXt` date time object to character representation in UTC time zone.
292		#'
293		#' Date times are stored as string representations expressed in the UTC time zone.
294		#' The storage format is `YYYY-MM-DD HH:MM:SS`.
295		#'
296		#' @param x (`POSIXt`) vector of date time values or anything else
297		#'
298		#' @return If `x` is of class `POSIXt`, a character vector, otherwise `x` itself.
299		#'
300		#' @keywords internal
301		format_time <- function(x) {
302	307x	if ("POSIXt" %in% class(x)) {
303	20x	format(x, format = "%Y-%m-%d %H:%M:%S", usetz = TRUE, tz = "UTC")
304		} else {
305	287x	x
306		}
307		}
308
309		#' Justify colons in `JSON` string
310		#'
311		#' This function takes a `JSON` string as input, splits it into lines, and pads element names
312		#' with spaces so that colons are justified between lines.
313		#'
314		#' @param json (`character(1)`) a `JSON` string.
315		#'
316		#' @return A list of character strings, which can be collapsed into a `JSON` string.
317		#'
318		#' @keywords internal
319		justify_json <- function(json) {
320	133x	format_name <- function(name, name_width) {
321	2806x	if (nchar(name) == 1 \|\| nchar(gsub("\\s", "", name)) <= 2) {
322	640x	name
323	2166x	} else if (grepl("slices\|attributes", name)) {
324	92x	paste0(name, ":")
325		} else {
326	2074x	paste(format(name, width = name_width), ":")
327		}
328		}
329	133x	json_lines <- strsplit(json, "\n")[[1]]
330	133x	json_lines_split <- regmatches(json_lines, regexpr(":", json_lines), invert = TRUE)
331	133x	name_width <- max(unlist(regexpr(":", json_lines))) - 1
332	133x	vapply(json_lines_split, function(x) paste0(format_name(x[1], name_width), stats::na.omit(x[2])), character(1))
333		}
334
335		#' Trim lines in `JSON` string
336		#'
337		#' This function takes a `JSON` string as input and returns a modified version of the
338		#' input where the values portion of each line is trimmed for a less messy console output.
339		#'
340		#' @param x (`character`)
341		#'
342		#' @return A character string trimmed after a certain hard-coded number of characters in the value portion.
343		#'
344		#' @keywords internal
345		#'
346		trim_lines_json <- function(x) {
347	123x	name_width <- max(unlist(gregexpr(":", x))) - 1
348	123x	trim_position <- name_width + 37L
349	123x	x_trim <- substr(x, 1, trim_position)
350	123x	substr(x_trim, trim_position - 2, trim_position) <- "..."
351	123x	x_trim
352		}
353
354		#' Default `teal_slice` id
355		#'
356		#' Create a slice id if none provided.
357		#'
358		#' Function returns a default `id` for a `teal_slice` object which needs
359		#' to be distinct from other `teal_slice` objects created for any
360		#' `FilterStates` object. Returned `id` can be treated as a location of
361		#' a vector on which `FilterState` is built:
362		#' - for a `data.frame` `id` concatenates `dataname` and `varname`.
363		#' - for a `MultiAssayExperiment` `id` concatenates `dataname`, `varname`,
364		#' `experiment` and `arg`, so that one can add `teal_slice` for a `varname`
365		#' which exists in multiple `SummarizedExperiment`s or exists in both `colData`
366		#' and `rowData` of given experiment.
367		#' For such a vector `teal.slice` doesn't allow to activate more than one filters.
368		#' In case of `teal_slice_expr` `id` is mandatory and must be unique.
369		#'
370		#' @param x (`teal_slice` or `list`)
371		#' @return (`character(1)`) `id` for a `teal_slice` object.
372		#'
373		#' @keywords internal
374		get_default_slice_id <- function(x) {
375	725x	checkmate::assert_multi_class(x, c("teal_slice", "list"))
376	725x	isolate({
377	725x	if (inherits(x, "teal_slice_expr") \|\| is.null(x$varname)) {
378	24x	x$id
379		} else {
380	701x	paste(
381	701x	Filter(
382	701x	length,
383	701x	as.list(x)[c("dataname", "varname", "experiment", "arg")]
384		),
385	701x	collapse = " "
386		)
387		}
388		})
389		}

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

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

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

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

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

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

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

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

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

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

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

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

1		#' Set "`<choice>:<label>`" type of names
2		#'
3		#' @description
4		#'
5		#' This is often useful for as it marks up the drop-down boxes for [shiny::selectInput()].
6		#'
7		#' @details
8		#' If either `choices` or `labels` are factors, they are coerced to character.
9		#' Duplicated elements from `choices` get removed.
10		#'
11		#' @param choices (`character` or `numeric` or `logical`) vector
12		#' @param labels (`character`) vector containing labels to be applied to `choices`. If `NA` then
13		#' "Label Missing" will be used.
14		#' @param types vector containing the types of the columns.
15		#'
16		#' @return A named character vector.
17		#'
18		#' @keywords internal
19		#'
20		choices_labeled <- function(choices, labels, types = NULL) {
21	42x	checkmate::assert_character(choices)
22	42x	checkmate::assert_character(labels[!is.na(labels)], len = length(choices))
23	39x	checkmate::assert_character(types, len = length(choices), null.ok = TRUE)
24
25	39x	is_dupl <- duplicated(choices)
26	39x	choices <- choices[!is_dupl]
27	39x	labels <- labels[!is_dupl]
28	39x	types <- types[!is_dupl]
29	39x	labels[is.na(labels)] <- "Label Missing"
30	39x	raw_labels <- labels
31	39x	combined_labels <- if (length(choices) > 0) {
32	39x	paste0(choices, ": ", labels)
33		} else {
34	!	character(0)
35		}
36
37	39x	choices <- structure(
38	39x	choices,
39	39x	names = combined_labels,
40	39x	raw_labels = raw_labels,
41	39x	combined_labels = combined_labels,
42	39x	class = c("choices_labeled", "character"),
43	39x	types = types
44		)
45
46	39x	choices
47		}

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

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

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

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

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

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

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

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