teal.slice coverage - 69.84%

Files
Source

# FilterState ------

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

  # public methods ----
  public = list(

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

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

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

      private$state_history <- reactiveVal(list())

      invisible(self)
    },

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

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

    #' @description
    #' Sets mutable parameters of the filter state.
    #' - `fixed` state is prevented from changing state
    #' - `anchored` state is prevented from removing state
    #'
    #' @param state (`teal_slice`)
    #'
    #' @return `self` invisibly
    #'
    set_state = function(state) {
      checkmate::assert_class(state, "teal_slice")
      if (private$is_fixed()) {
        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() }")
        isolate({
          if (!is.null(state$selected)) {
            private$set_selected(state$selected)
          }
          if (!is.null(state$keep_na)) {
            private$set_keep_na(state$keep_na)
          }
          if (!is.null(state$keep_inf)) {
            private$set_keep_inf(state$keep_inf)
          }
          current_state <- sprintf(
            "selected: %s; keep_na: %s; keep_inf: %s",
            toString(private$get_selected()),
            private$get_keep_na(),
            private$get_keep_inf()
          )
        })
      }

      invisible(self)
    },


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

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

    #' @description
    #' `shiny` module server.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #'
    #' @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("FilterState$server initializing module for slice: { private$get_id() } ")
          private$server_summary("summary")
          if (private$is_fixed()) {
            private$server_inputs_fixed("inputs")
          } else {
            private$server_inputs("inputs")
          }

          private$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 FilterState 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 = "panel 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 = "filter-card-title",
            if (private$is_anchored() && private$is_fixed()) {
              icon("anchor-lock", class = "filter-card-icon")
            } else if (private$is_anchored() && !private$is_fixed()) {
              icon("anchor", class = "filter-card-icon")
            } else if (!private$is_anchored() && private$is_fixed()) {
              icon("lock", class = "filter-card-icon")
            },
            tags$div(class = "filter-card-varname", tags$strong(private$get_varname())),
            tags$div(class = "filter-card-varlabel", private$get_varlabel()),
            tags$div(
              class = "filter-card-controls",
              # Suppress toggling body when clicking on this div.
              # This is for bootstrap 3 and 4. Causes page to scroll to top, prevented by setting href on buttons.
              onclick = "event.stopPropagation();event.preventDefault();",
              # This is for bootstrap 5.
              `data-bs-toggle` = "collapse",
              `data-bs-target` = NULL,
              if (isFALSE(private$is_fixed())) {
                actionLink(
                  inputId = ns("back"),
                  label = NULL,
                  icon = icon("circle-arrow-left", lib = "font-awesome"),
                  title = "Rewind state",
                  class = "filter-card-back",
                  style = "display: none"
                )
              },
              if (isFALSE(private$is_fixed())) {
                actionLink(
                  inputId = ns("reset"),
                  label = NULL,
                  icon = icon("circle-arrow-up", lib = "font-awesome"),
                  title = "Restore original state",
                  class = "filter-card-back",
                  style = "display: none"
                )
              },
              if (isFALSE(private$is_anchored())) {
                actionLink(
                  inputId = ns("remove"),
                  label = icon("circle-xmark", lib = "font-awesome"),
                  title = "Remove filter",
                  class = "filter-card-remove"
                )
              }
            )
          ),
          tags$div(class = "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 = "filter-card-body",
            if (private$is_fixed()) {
              private$ui_inputs_fixed(ns("inputs"))
            } else {
              private$ui_inputs(ns("inputs"))
            }
          )
        )
      )
    },

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

  # 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) {
      logger::log_debug(
        sprintf(
          "%s$set_selected setting selection of id: %s",
          class(self)[1],
          private$get_id()
        )
      )
      isolate({
        value <- private$cast_and_validate(value)
        value <- private$check_length(value)
        value <- private$remove_out_of_bounds_values(value)
        private$teal_slice$selected <- value
      })

      invisible(NULL)
    },

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

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

      invisible(NULL)
    },

    # getters for state features ----

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

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

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

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

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

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

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

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

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

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

    # other ----

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

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

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

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

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

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

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

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

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

    # shiny modules -----

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

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

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

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

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

    # @description
    # Module UI function displaying input to keep or remove NA in the `FilterState` call.
    # Renders a checkbox input only when variable with which `FilterState` has been created contains NAs.
    # @param id (`character(1)`) `shiny` module instance id.
    keep_na_ui = function(id) {
      ns <- NS(id)
      if (private$na_count > 0) {
        isolate({
          countmax <- private$na_count
          countnow <- private$filtered_na_count()
          ui_input <- checkboxInput(
            inputId = ns("value"),
            label = 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("FilterState$keep_na_srv@1 changed reactive value, id: { private$get_id() }")
              updateCheckboxInput(
                inputId = "value",
                label = sprintf("Keep NA (%s/%s)", private$filtered_na_count(), private$na_count),
                value = private$get_keep_na()
              )
            }
          }
        )
        private$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("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
            keep_na <- if (is.null(input$value)) {
              FALSE
            } else {
              input$value
            }
            private$set_keep_na(keep_na)
          }
        )
        invisible(NULL)
      })
    }
  )
)

# DateFilterState ------

#' @name DateFilterState
#' @docType class
#'
#' @title `FilterState` object for `Date` data
#'
#' @description Manages choosing a range of `Date`s.
#'
#' @examples
#' # use non-exported function from teal.slice
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
#' DateFilterState <- getFromNamespace("DateFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- DateFilterState$new(
#'   x = c(Sys.Date() + seq(1:10), NA),
#'   slice = teal_slice(varname = "x", dataname = "data"),
#'   extract_type = character(0)
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#'   teal_slice(
#'     dataname = "data",
#'     varname = "x",
#'     selected = c(Sys.Date() + 3L, Sys.Date() + 8L),
#'     keep_na = TRUE
#'   )
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' dates <- c(Sys.Date() - 100, Sys.Date())
#' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA)
#' fs <- DateFilterState$new(
#'   x = data_date,
#'   slice = teal_slice(
#'     dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE
#'   )
#' )
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   include_css_files(pattern = "filter-panel"),
#'   include_js_files(pattern = "count-bar-labels"),
#'   column(4, tags$div(
#'     tags$h4("DateFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, tags$div(
#'     id = "outputs", # div id is needed for toggling the element
#'     tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_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()
#'   )),
#'   column(4, 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(
            class = "flex",
            actionButton(
              class = "date_reset_button",
              inputId = ns("start_date_reset"),
              label = NULL,
              icon = icon("fas fa-undo")
            ),
            tags$div(
              class = "w-80 filter_datelike_input",
              dateRangeInput(
                inputId = ns("selection"),
                label = NULL,
                start = private$get_selected()[1],
                end = private$get_selected()[2],
                min = private$get_choices()[1L],
                max = private$get_choices()[2L],
                width = "100%"
              )
            ),
            actionButton(
              class = "date_reset_button",
              inputId = ns("end_date_reset"),
              label = NULL,
              icon = icon("fas fa-undo")
            )
          ),
          private$keep_na_ui(ns("keep_na"))
        )
      })
    },

    # @description
    # Server module
    # @param id (`character(1)`) `shiny` module instance id.
    # @return `NULL`.
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_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 = "filter-card-summary-value",
          HTML(min, "&ndash;", max)
        ),
        tags$span(
          class = "filter-card-summary-controls",
          if (private$na_count > 0) {
            tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
          }
        )
      )
    }
  )
)

#' Managing `FilteredData` states
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Set, get and remove filter states of `FilteredData` object.
#'
#' @name filter_state_api
#'
#' @param datasets (`FilteredData`)
#'   object to store filter state and filtered datasets, shared across modules
#'
#'   see [`FilteredData`] for details
#'
#' @param filter (`teal_slices`)
#'   specify filters in place on app start-up
#'
#' @param force (`logical(1)`)
#'   flag specifying whether to include anchored filter states.
#'
#' @return
#' - `set_*`, `remove_*` and `clear_filter_state` return `NULL` invisibly
#' - `get_filter_state` returns a named `teal_slices` object
#'    containing a `teal_slice` for every existing `FilterState`
#'
#' @seealso [`teal_slice`]
#'
#' @examples
#' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars))
#' fs <- teal_slices(
#'   teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor")),
#'   teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)),
#'   teal_slice(dataname = "mtcars", varname = "gear", selected = c(4, 5)),
#'   teal_slice(dataname = "mtcars", varname = "carb", selected = c(4, 10))
#' )
#'
#' # set initial filter state
#' set_filter_state(datasets, filter = fs)
#'
#' # get filter state
#' get_filter_state(datasets)
#'
#' # modify filter state
#' set_filter_state(
#'   datasets,
#'   teal_slices(
#'     teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)
#'   )
#' )
#'
#' # remove specific filters
#' remove_filter_state(
#'   datasets,
#'   teal_slices(
#'     teal_slice(dataname = "iris", varname = "Species"),
#'     teal_slice(dataname = "mtcars", varname = "gear"),
#'     teal_slice(dataname = "mtcars", varname = "carb")
#'   )
#' )
#'
#' # remove all states
#' clear_filter_states(datasets)
#'
#' @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 `r lifecycle::badge("stable")`
#'
#' To be used in `Show R Code` button.
#'
#' @param datasets (`FilteredData`)
#' @param datanames (`character`) vector of dataset names
#'
#' @return A character string containing all subset expressions.
#'
#' @export
#'
get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
  checkmate::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"
  )
}

#' 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
  if (
    !is.null(getDefaultReactiveDomain()) &&
      !getDefaultReactiveDomain()$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)
}

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

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

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

  do.call(FilterState$new, args)
}

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

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

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

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

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

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

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

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

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

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

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


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


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

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

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

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

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

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

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

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

  paste0(color_specification[color], alpha)
}

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

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

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

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

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

      invisible(NULL)
    },

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

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

      invisible(NULL)
    },


    # shiny modules -----

    #' @description
    #' top-level `shiny` module for the filter panel in the `teal` app.
    #' Contains 1) filter overview panel, 2) filter active panel, and 3) add filters panel.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @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)
      tags$div(
        id = ns(NULL), # used for hiding / showing
        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
        class = "well",
        include_js_files(pattern = "togglePanelItems"),
        tags$div(
          style = "display: flex; justify-content: space-between;",
          tags$span("Active Filter Variables", class = "text-primary", style = "font-weight: 700;"),
          tags$div(
            style = "min-width: 60px;",
            uiOutput(ns("remove_all_filters_ui")),
            tags$a(
              class = "remove_all",
              tags$i(
                class = "fa fa-angle-down",
                title = "fold/expand ...",
                onclick = sprintf(
                  "togglePanelItems(this, ['%s', '%s'], 'fa-angle-down', 'fa-angle-right');",
                  ns("filter_active_vars_contents"),
                  ns("filters_active_count")
                )
              )
            ),
            private$ui_available_filters(ns("available_filters"))
          )
        ),
        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), allow_add = private$allow_add)
              }
            )
          )
        ),
        tags$div(
          id = ns("filters_active_count"),
          style = "display: none;",
          textOutput(ns("teal_filters_count"))
        )
      )
    },

    #' @description
    #' Server module responsible for displaying active filters.
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param active_datanames (`reactive`)
    #'   defining subset of `self$datanames()` to be displayed.
    #' @return `NULL`.
    srv_active = function(id, active_datanames = self$datanames) {
      checkmate::assert_function(active_datanames)
      moduleServer(id, function(input, output, session) {
        logger::log_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())
          actionLink(
            inputId = session$ns("remove_all_filters"),
            label = "",
            icon("circle-xmark", lib = "font-awesome"),
            title = "Remove active filters",
            class = "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()
            logger::log_debug("FilteredData$srv_filter_panel@1 removed all non-anchored filters")
          }
        )

        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(
        id = id, # not used, can be used to customize CSS behavior
        class = "well",
        tags$div(
          class = "row",
          tags$div(
            class = "col-sm-9",
            tags$label("Active Filter Summary", class = "text-primary mb-4")
          ),
          tags$div(
            class = "col-sm-3",
            tags$a(
              class = "filter-icon",
              tags$i(
                class = "fa fa-angle-down",
                title = "fold/expand ...",
                onclick = sprintf(
                  "togglePanelItems(this, '%s', 'fa-angle-down', 'fa-angle-right');",
                  ns("filters_overview_contents")
                )
              )
            )
          )
        ),
        tags$div(
          id = ns("filters_overview_contents"),
          tags$div(
            class = "teal_active_summary_filter_panel",
            tableOutput(ns("table"))
          )
        )
      )
    },

    #' @description
    #' Server function to display the number of records in the filtered and unfiltered
    #' data.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @param active_datanames (`reactive`)
    #'   returning `datanames` that should be shown on the filter panel,
    #'   must be a subset of the `datanames` argument provided to `ui_filter_panel`;
    #'   if the function returns `NULL` (as opposed to `character(0)`), the filter
    #'   panel will be hidden.
    #' @return `NULL`.
    srv_overview = function(id, active_datanames = self$datanames) {
      checkmate::assert_class(active_datanames, "reactive")
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_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 = "table custom-table",
              tags$thead(header_html),
              tags$tbody(body_html)
            )
            logger::log_debug("FilteredData$srv_filter_overview@1 updated counts")
            table_html
          })

          NULL
        }
      )
    },

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

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

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

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

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

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

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

# 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$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: { private$dataname }")
        }
        env <- new.env(parent = parent.env(globalenv()))
        env[[dataname]] <- private$dataset
        filter_call <- self$get_call(sid)
        eval_expr_with_msg(filter_call, env)
        get(x = dataname, envir = env)
      }

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

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

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

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

    # managing filter states -----

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

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

    #' @description
    #' Set filter state.
    #'
    #' @param state (`teal_slices`)
    #'
    #' @return Virtual method, returns nothing and raises error.
    #'
    set_filter_state = function(state) {
      stop("set_filter_state is an abstract class method.")
    },

    #' @description
    #' Gets the 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.
    #' @param allow_add (`logical(1)`)
    #'   logical flag specifying whether the user will be able to add new filters
    #'
    #' @return `shiny.tag`
    ui_active = function(id, allow_add = TRUE) {
      dataname <- self$get_dataname()
      checkmate::assert_string(dataname)

      ns <- NS(id)
      if_multiple_filter_states <- length(private$get_filter_states()) > 1
      tags$span(
        id = id,
        include_css_files("filter-panel"),
        include_js_files(pattern = "icons"),
        tags$div(
          id = ns("whole_ui"), # to hide it entirely
          fluidRow(
            style = "padding: 0px 15px 0px 15px;",
            tags$div(
              style = "display: flex; align-items: center; justify-content: space-between;",
              tags$div(
                style = "display: flex;",
                tags$span(dataname, class = "filter_panel_dataname"),
                if (allow_add) {
                  tags$a(
                    class = "filter-icon add-filter",
                    tags$i(
                      id = ns("add_filter_icon"),
                      class = "fa fa-plus",
                      title = "fold/expand transform panel",
                      onclick = sprintf(
                        "togglePanelItems(this, '%s', 'fa-plus', 'fa-minus');",
                        ns("add_panel")
                      )
                    )
                  )
                }
              ),
              tags$div(
                style = "min-width: 40px; z-index: 1; display: flex; justify-content: flex-end;",
                uiOutput(ns("collapse_ui")),
                uiOutput(ns("remove_filters_ui"))
              )
            ),
            if (allow_add) {
              tags$div(
                id = ns("add_panel"),
                class = "add-panel",
                style = "display: none;",
                self$ui_add(ns(private$dataname))
              )
            }
          ),
          tags$div(
            id = ns("filter_count_ui"),
            style = "display: none;",
            tagList(
              textOutput(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 = ns("filters"),
            class = "parent-hideable-list-group",
            tagList(
              lapply(
                names(private$get_filter_states()),
                function(x) {
                  tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x)))
                }
              )
            )
          )
        )
      )
    },

    #' @description
    #' Server module for a dataset active filters.
    #'
    #' @param id (`character(1)`)
    #'   `shiny` module instance id.
    #' @return `NULL`.
    srv_active = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          dataname <- self$get_dataname()
          logger::log_debug("FilteredDataset$srv_active initializing, dataname: { dataname }")
          checkmate::assert_string(dataname)

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

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

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

          is_filter_collapsible <- reactive({
            filter_count() != 0
          })

          output$collapse_ui <- renderUI({
            req(is_filter_collapsible())
            tags$a(
              id = session$ns("collapse"),
              class = "filter-icon",
              tags$i(
                id = session$ns("collapse_icon"),
                class = "fa fa-angle-down",
                title = "fold/expand dataset filters",
                # TODO: clickWhenClassPresent() is used to hide the add_ui pannel during a collapse of the UI.
                # In the future, it should be completely handled by collapsing the UI by positioning.
                onclick = sprintf(
                  "togglePanelItems(this, ['%s', '%s'], 'fa-angle-down', 'fa-angle-right');
                  clickWhenClassPresent('%s', 'fa-minus', this.classList.contains('fa-angle-right'));",
                  session$ns("filter_count_ui"),
                  session$ns("filters"),
                  session$ns("add_filter_icon")
                )
              )
            )
          })

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

          private$session_bindings[[session$ns("get_filter_state")]] <- observeEvent(
            self$get_filter_state(),
            ignoreInit = TRUE,
            {
              shinyjs::hide("filter_count_ui")
              shinyjs::show("filters")
              shinyjs::toggle("remove_filters_ui", condition = is_filter_removable())
              shinyjs::toggle("collapse_ui", condition = is_filter_collapsible())
              shinyjs::runjs(
                sprintf(
                  "setAndRemoveClass('#%s', 'fa-angle-down', 'fa-angle-right')",
                  session$ns("collapse_icon")
                )
              )
            }
          )

          output$remove_filters_ui <- renderUI({
            req(is_filter_removable())
            actionLink(
              session$ns("remove_filters"),
              label = "",
              icon = icon("circle-xmark", lib = "font-awesome"),
              class = "filter-icon"
            )
          })

          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()
            logger::log_debug("FilteredDataset$srv_active@1 removed all non-anchored filters, dataname: { dataname }")
          })

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



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

1		#' Managing `FilteredData` states
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' Set, get and remove filter states of `FilteredData` object.
6		#'
7		#' @name filter_state_api
8		#'
9		#' @param datasets (`FilteredData`)
10		#' object to store filter state and filtered datasets, shared across modules
11		#'
12		#' see [`FilteredData`] for details
13		#'
14		#' @param filter (`teal_slices`)
15		#' specify filters in place on app start-up
16		#'
17		#' @param force (`logical(1)`)
18		#' flag specifying whether to include anchored filter states.
19		#'
20		#' @return
21		#' - `set_`, `remove_` and `clear_filter_state` return `NULL` invisibly
22		#' - `get_filter_state` returns a named `teal_slices` object
23		#' containing a `teal_slice` for every existing `FilterState`
24		#'
25		#' @seealso [`teal_slice`]
26		#'
27		#' @examples
28		#' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars))
29		#' fs <- teal_slices(
30		#' teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor")),
31		#' teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)),
32		#' teal_slice(dataname = "mtcars", varname = "gear", selected = c(4, 5)),
33		#' teal_slice(dataname = "mtcars", varname = "carb", selected = c(4, 10))
34		#' )
35		#'
36		#' # set initial filter state
37		#' set_filter_state(datasets, filter = fs)
38		#'
39		#' # get filter state
40		#' get_filter_state(datasets)
41		#'
42		#' # modify filter state
43		#' set_filter_state(
44		#' datasets,
45		#' teal_slices(
46		#' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)
47		#' )
48		#' )
49		#'
50		#' # remove specific filters
51		#' remove_filter_state(
52		#' datasets,
53		#' teal_slices(
54		#' teal_slice(dataname = "iris", varname = "Species"),
55		#' teal_slice(dataname = "mtcars", varname = "gear"),
56		#' teal_slice(dataname = "mtcars", varname = "carb")
57		#' )
58		#' )
59		#'
60		#' # remove all states
61		#' clear_filter_states(datasets)
62		#'
63		#' @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	3x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
122	3x	checkmate::assert_class(filter, "teal_slices")
123	3x	datasets$set_filter_state(filter)
124	3x	invisible(NULL)
125		}
126
127		#' @rdname filter_state_api
128		#' @export
129		get_filter_state <- function(datasets) {
130	4x	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
131	4x	if (isRunning()) {
132	!	datasets$get_filter_state()
133		} else {
134	4x	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 `r lifecycle::badge("stable")`
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		#' 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	12x	checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE)
13	12x	js_files <- list.files(
14	12x	system.file("js", package = "teal.slice", mustWork = TRUE),
15	12x	pattern = pattern,
16	12x	full.names = TRUE
17		)
18	12x	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	55x	if (length(choices) > 1) {
39	27x	do.call("call", append(list("c"), choices))
40		} else {
41	28x	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		if (
58	1320x	!is.null(getDefaultReactiveDomain()) &&
59	1320x	!getDefaultReactiveDomain()$isEnded()
60		) {
61	286x	lapply(private$session_bindings, function(x) x$destroy())
62		}
63	1320x	invisible(NULL)
64		}
65
66
67
68		#' Encodes ids to be used in JavaScript and Shiny
69		#'
70		#' @description
71		#' Replaces non-ASCII characters into a format that can be used in HTML,
72		#' JavaScript and Shiny.
73		#'
74		#' When the id has a character that is not allowed, it is replaced with `"_"`
75		#' and a 4 character hash of the original id is added to the start of the
76		#' resulting id.
77		#'
78		#'
79		#' @param id (`character(1)`) The id string.
80		#'
81		#' @return Sanitized string that removes special characters and spaces.
82		#'
83		#' @keywords internal
84		sanitize_id <- function(id) {
85	392x	pattern_escape <- "[^0-9A-Za-z_]"
86
87	392x	id_new <- gsub(pattern_escape, "_", id, perl = TRUE)
88	392x	hashes <- vapply(id[id != id_new], rlang::hash, character(1), USE.NAMES = FALSE)
89
90	392x	id[id != id_new] <- paste0("h", substr(hashes, 1, 4), "_", id_new[id != id_new])
91	392x	id
92		}
93
94		#' `NS` wrapper to sanitize ids for shiny
95		#'
96		#' Special characters and spaces are not allowed in shiny ids (in JS)
97		#'
98		#' @noRd
99		NS <- function(namespace, id = NULL) { # nolint: object_name.
100	148x	if (!missing(id)) {
101	3x	return(shiny::NS(namespace, sanitize_id(id)))
102		}
103
104	145x	function(id) {
105	282x	shiny::NS(namespace, sanitize_id(id))
106		}
107		}
108
109		#' `moduleServer` wrapper to sanitize ids for shiny
110		#'
111		#' Special characters and spaces are not allowed in shiny ids (in JS)
112		#'
113		#' @noRd
114		moduleServer <- function(id, module, session = getDefaultReactiveDomain()) { # nolint: object_name.
115	107x	id <- sanitize_id(id)
116	107x	shiny::moduleServer(id, module, session)
117		}

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

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	19x	checkmate::assert_multi_class(data, c("data.frame", "DataFrame", "matrix"))
40	19x	checkmate::assert_character(columns, any.missing = FALSE, null.ok = TRUE)
41	19x	checkmate::assert_subset(columns, colnames(data))
42
43	19x	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	18x	types <- vapply(data, function(x) class(x)[1L], character(1L))
54	18x	if (!is.null(columns)) types <- types[columns]
55		# alternative after R 4.4.0: `types <- types[columns %\|\|% TRUE]`
56		}
57	19x	types
58		}

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