teal.slice coverage - 57.02%

Files
Source

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

  # public methods ----
  public = list(
    #' @description Initializes `MAEFilterStates` object
    #'
    #' Initialize `MAEFilterStates` object
    #'
    #' @param dataname (`character(1)`)\cr
    #'   name of the data used in the expression
    #'   specified to the function argument attached to this `FilterStates`.
    #'
    #' @param datalabel (`character(0)` or `character(1)`)\cr
    #'   text label value.
    #'
    #' @param varlabels (`character`)\cr
    #'   labels of the variables used in this object
    #'
    #' @param keys (`character`)\cr
    #'   key columns names
    initialize = function(dataname, datalabel, varlabels, keys) {
      if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
        stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
      }
      super$initialize(dataname, datalabel)
      private$keys <- keys
      private$varlabels <- varlabels
      private$state_list <- list(
        y = reactiveVal()
      )
      return(invisible(self))
    },

    #' @description
    #' Returns the formatted string representing this `MAEFilterStates` object.
    #'
    #' @param indent (`numeric(1)`) the number of spaces before each line of the representation
    #' @return `character(1)` the formatted string
    format = function(indent = 0) {
      checkmate::assert_number(indent, finite = TRUE, lower = 0)

      if (length(self$state_list_get(1L)) > 0) {
        formatted_states <- sprintf("%sSubject filters:", format("", width = indent))
        for (state in self$state_list_get(1L)) {
          formatted_states <- c(formatted_states, state$format(indent = indent + 2))
        }
        paste(formatted_states, collapse = "\n")
      }
    },

    #' @description
    #' Returns function name used to create filter call.
    #' For `MAEFilterStates` `MultiAssayExperiment::subsetByColData` is used.
    #' @return `character(1)`
    get_fun = function() {
      "MultiAssayExperiment::subsetByColData"
    },

    #' @description
    #' Server module
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @return `moduleServer` function which returns `NULL`
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          previous_state <- reactiveVal(isolate(self$state_list_get("y")))
          added_state_name <- reactiveVal(character(0))
          removed_state_name <- reactiveVal(character(0))

          observeEvent(self$state_list_get("y"), {
            added_state_name(setdiff(names(self$state_list_get("y")), names(previous_state())))
            removed_state_name(setdiff(names(previous_state()), names(self$state_list_get("y"))))

            previous_state(self$state_list_get("y"))
          })

          observeEvent(added_state_name(), ignoreNULL = TRUE, {
            fstates <- self$state_list_get("y")
            html_ids <- private$map_vars_to_html_ids(names(fstates))
            for (fname in added_state_name()) {
              private$insert_filter_state_ui(
                id = html_ids[fname],
                filter_state = fstates[[fname]],
                state_list_index = "y",
                state_id = fname
              )
            }
            added_state_name(character(0))
          })

          observeEvent(removed_state_name(), {
            req(removed_state_name())
            for (fname in removed_state_name()) {
              private$remove_filter_state_ui("y", fname, .input = input)
            }
            removed_state_name(character(0))
          })
          NULL
        }
      )
    },

    #' @description
    #' Returns active `FilterState` objects.
    #'
    #' Gets all active filters from this dataset in form of the nested list.
    #' The output list can be used as input to `self$set_filter_state`.
    #'
    #' @return `list` with elements number equal number of `FilterStates`.
    get_filter_state = function() {
      lapply(self$state_list_get(state_list_index = "y"), function(x) x$get_state())
    },

    #' @description
    #' Set filter state
    #'
    #' @param data (`MultiAssayExperiment`)\cr
    #'   data which are supposed to be filtered.
    #' @param state (`named list`)\cr
    #'   should contain values which are initial selection in the `FilterState`.
    #'   Names of the `list` element should correspond to the name of the
    #'   column in `colData(data)`.
    #' @param ... ignored.
    #' @return `NULL`
    set_filter_state = function(data, state, ...) {
      checkmate::assert_class(data, "MultiAssayExperiment")
      checkmate::assert(
        checkmate::check_subset(names(state), names(SummarizedExperiment::colData(data))),
        checkmate::check_class(state, "default_filter"),
        combine = "or"
      )
      logger::log_trace("MAEFilterState$set_filter_state initializing, dataname: { private$dataname }")
      filter_states <- self$state_list_get("y")
      for (varname in names(state)) {
        value <- resolve_state(state[[varname]])
        if (varname %in% names(filter_states)) {
          fstate <- filter_states[[varname]]
          fstate$set_state(value)
        } else {
          fstate <- init_filter_state(
            SummarizedExperiment::colData(data)[[varname]],
            varname = varname,
            varlabel = private$get_varlabels(varname),
            dataname = private$dataname,
            extract_type = "list"
          )
          fstate$set_state(value)
          fstate$set_na_rm(TRUE)
          self$state_list_push(
            x = fstate,
            state_list_index = "y",
            state_id = varname
          )
        }
      }
      logger::log_trace("MAEFilterState$set_filter_state initialized, dataname: { private$dataname }")
      NULL
    },

    #' @description
    #' Removes a variable from the `state_list` and its corresponding UI element.
    #'
    #' @param state_id (`character(1)`)\cr name of `state_list` element.
    #'
    #' @return `NULL`
    #'
    remove_filter_state = function(state_id) {
      logger::log_trace(
        sprintf(
          "%s$remove_filter_state for %s called, dataname: %s",
          class(self)[1],
          state_id,
          private$dataname
        )
      )

      if (!state_id %in% names(self$state_list_get("y"))) {
        warning(paste(
          "Variable:", state_id,
          "is not present in the actual active filters of dataset: { private$dataname }",
          "therefore no changes are applied."
        ))
        logger::log_warn(
          paste(
            "Variable:", state_id, "is not present in the actual active filters of dataset:",
            "{ private$dataname } therefore no changes are applied."
          )
        )
      } else {
        self$state_list_remove(state_list_index = "y", state_id = state_id)
        logger::log_trace(
          sprintf(
            "%s$remove_filter_state for variable %s done, dataname: %s",
            class(self)[1],
            state_id,
            private$dataname
          )
        )
      }
    },

    # shiny modules ----

    #' @description
    #' Shiny UI module to add filter variable
    #' @param id (`character(1)`)\cr
    #'  id of shiny module
    #' @param data (`MultiAssayExperiment`)\cr
    #'  object containing `colData` which columns are used to be used
    #'  to choose filter variables
    #'
    #' @return `shiny.tag`
    #'
    ui_add_filter_state = function(id, data) {
      checkmate::assert_string(id)
      stopifnot(is(data, "MultiAssayExperiment"))

      ns <- NS(id)

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

    #' @description
    #' Shiny server module to add filter variable.
    #'
    #' Module controls available choices to select as a filter variable.
    #' Selected filter variable is being removed from available choices.
    #' Removed filter variable gets back to available choices.
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param data (`MultiAssayExperiment`)\cr
    #'  object containing `colData` which columns are used to choose filter variables in
    #' [teal.widgets::optionalSelectInput()].
    #' @param ... ignored
    #'
    #' @return `moduleServer` function which returns `NULL`
    #'
    srv_add_filter_state = function(id, data, ...) {
      stopifnot(is(data, "MultiAssayExperiment"))
      check_ellipsis(..., stop = FALSE)
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace(
            "MAEFilterState$srv_add_filter_state initializing, dataname: { private$dataname }"
          )
          shiny::setBookmarkExclude("var_to_add")
          active_filter_vars <- reactive({
            vapply(
              X = self$state_list_get(state_list_index = "y"),
              FUN.VALUE = character(1),
              FUN = function(x) x$get_varname()
            )
          })

          # available choices to display
          avail_column_choices <- reactive({
            choices <- setdiff(
              get_supported_filter_varnames(data = SummarizedExperiment::colData(data)),
              active_filter_vars()
            )
            data_choices_labeled(
              data = SummarizedExperiment::colData(data),
              choices = choices,
              varlabels = private$get_varlabels(choices),
              keys = private$keys
            )
          })
          observeEvent(
            avail_column_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_trace(paste(
                "MAEFilterStates$srv_add_filter_state@1 updating available column choices,",
                "dataname: { private$dataname }"
              ))
              if (is.null(avail_column_choices())) {
                shinyjs::hide("var_to_add")
              } else {
                shinyjs::show("var_to_add")
              }
              teal.widgets::updateOptionalSelectInput(
                session,
                "var_to_add",
                choices = avail_column_choices()
              )
              logger::log_trace(paste(
                "MAEFilterStates$srv_add_filter_state@1 updated available column choices,",
                "dataname: { private$dataname }"
              ))
            }
          )

          observeEvent(
            eventExpr = input$var_to_add,
            handlerExpr = {
              logger::log_trace(
                sprintf(
                  "MAEFilterStates$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s",
                  deparse1(input$var_to_add),
                  private$dataname
                )
              )
              fstate <- init_filter_state(
                SummarizedExperiment::colData(data)[[input$var_to_add]],
                varname = input$var_to_add,
                varlabel = private$get_varlabels(input$var_to_add),
                dataname = private$dataname,
                extract_type = "list"
              )
              fstate$set_na_rm(TRUE)

              self$state_list_push(
                x = fstate,
                state_list_index = "y",
                state_id = input$var_to_add
              )
              logger::log_trace(
                sprintf(
                  "MAEFilterStates$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s",
                  deparse1(input$var_to_add),
                  private$dataname
                )
              )
            }
          )

          logger::log_trace(
            "MAEFilterState$srv_add_filter_state initialized, dataname: { private$dataname }"
          )
          NULL
        }
      )
    }
  ),

  # private members ----
  private = list(
    varlabels = character(0),
    keys = character(0),
    #' description
    #' Get label of specific variable. In case when variable label is missing
    #' name of the variable is returned.
    #' parameter variable (`character`)\cr
    #'  name of the variable for which label should be returned
    #' return `character`
    get_varlabels = function(variables = character(0)) {
      checkmate::assert_character(variables)
      if (identical(variables, character(0))) {
        private$varlabels
      } else {
        varlabels <- private$varlabels[variables]
        missing_labels <- is.na(varlabels) | varlabels == ""
        varlabels[missing_labels] <- variables[missing_labels]
        varlabels
      }
    }
  )
)

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

  # public methods ----
  public = list(
    #' @description Initialize `SEFilterStates` object
    #'
    #' Initialize `SEFilterStates` object
    #'
    #' @param dataname (`character(1)`)\cr
    #'   name of the data used in the expression
    #'   specified to the function argument attached to this `FilterStates`.
    #'
    #' @param datalabel (`character(0)` or `character(1)`)\cr
    #'   text label value.
    initialize = function(dataname, datalabel) {
      if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
        stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
      }
      super$initialize(dataname, datalabel)
      private$state_list <- list(
        subset = reactiveVal(),
        select = reactiveVal()
      )
    },

    #' @description
    #' Returns the formatted string representing this `MAEFilterStates` object.
    #'
    #' @param indent (`numeric(1)`) the number of spaces before each line of the representation
    #' @return `character(1)` the formatted string
    format = function(indent = 0) {
      checkmate::assert_number(indent, finite = TRUE, lower = 0)

      whitespace_indent <- format("", width = indent)
      formatted_states <- c()
      if (!is.null(self$state_list_get(state_list_index = "subset"))) {
        formatted_states <- c(formatted_states, paste0(whitespace_indent, "  Subsetting:"))
        for (state in self$state_list_get(state_list_index = "subset")) {
          formatted_states <- c(formatted_states, state$format(indent = indent + 4))
        }
      }

      if (!is.null(self$state_list_get(state_list_index = "select"))) {
        formatted_states <- c(formatted_states, paste0(whitespace_indent, "  Selecting:"))
        for (state in self$state_list_get(state_list_index = "select")) {
          formatted_states <- c(formatted_states, state$format(indent = indent + 4))
        }
      }

      if (length(formatted_states) > 0) {
        formatted_states <- c(paste0(whitespace_indent, "Assay ", self$get_datalabel(), " filters:"), formatted_states)
        paste(formatted_states, collapse = "\n")
      }
    },

    #' @description
    #' Server module
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @return `moduleServer` function which returns `NULL`
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          previous_state_subset <- reactiveVal(isolate(self$state_list_get("subset")))
          added_state_name_subset <- reactiveVal(character(0))
          removed_state_name_subset <- reactiveVal(character(0))

          observeEvent(self$state_list_get("subset"), {
            added_state_name_subset(
              setdiff(names(self$state_list_get("subset")), names(previous_state_subset()))
            )
            removed_state_name_subset(
              setdiff(names(previous_state_subset()), names(self$state_list_get("subset")))
            )
            previous_state_subset(self$state_list_get("subset"))
          })

          observeEvent(added_state_name_subset(), ignoreNULL = TRUE, {
            fstates <- self$state_list_get("subset")
            html_ids <- private$map_vars_to_html_ids(keys = names(fstates), prefix = "rowData")
            for (fname in added_state_name_subset()) {
              private$insert_filter_state_ui(
                id = html_ids[fname],
                filter_state = fstates[[fname]],
                state_list_index = "subset",
                state_id = fname
              )
            }
            added_state_name_subset(character(0))
          })

          observeEvent(removed_state_name_subset(), {
            req(removed_state_name_subset())
            for (fname in removed_state_name_subset()) {
              private$remove_filter_state_ui("subset", fname, .input = input)
            }
            removed_state_name_subset(character(0))
          })

          # select
          previous_state_select <- reactiveVal(isolate(self$state_list_get("select")))
          added_state_name_select <- reactiveVal(character(0))
          removed_state_name_select <- reactiveVal(character(0))

          observeEvent(self$state_list_get("select"), {
            # find what has been added or removed
            added_state_name_select(
              setdiff(names(self$state_list_get("select")), names(previous_state_select()))
            )
            removed_state_name_select(
              setdiff(names(previous_state_select()), names(self$state_list_get("select")))
            )
            previous_state_select(self$state_list_get("select"))
          })

          observeEvent(added_state_name_select(), ignoreNULL = TRUE, {
            fstates <- self$state_list_get("select")
            html_ids <- private$map_vars_to_html_ids(keys = names(fstates), prefix = "colData")
            for (fname in added_state_name_select()) {
              private$insert_filter_state_ui(
                id = html_ids[fname],
                filter_state = fstates[[fname]],
                state_list_index = "select",
                state_id = fname
              )
            }
            added_state_name_select(character(0))
          })

          observeEvent(removed_state_name_select(), {
            req(removed_state_name_select())
            for (fname in removed_state_name_select()) {
              private$remove_filter_state_ui("select", fname, .input = input)
            }
            removed_state_name_select(character(0))
          })
          NULL
        }
      )
    },

    #' @description
    #' Gets the reactive values from the active `FilterState` objects.
    #'
    #' Gets all active filters from this dataset in form of the nested list.
    #' The output list is a compatible input to `self$set_filter_state`.
    #'
    #' @return `list` containing one or two lists  depending on the number of
    #' `state_list` object (I.e. if `rowData` and `colData` exist). Each
    #' `list` contains elements number equal to number of active filter variables.
    get_filter_state = function() {
      states <- sapply(
        X = names(private$state_list),
        simplify = FALSE,
        function(x) {
          lapply(self$state_list_get(state_list_index = x), function(xx) xx$get_state())
        }
      )
      Filter(function(x) length(x) > 0, states)
    },

    #' @description
    #' Set filter state
    #'
    #' @param data (`SummarizedExperiment`)\cr
    #'   data which are supposed to be filtered.
    #' @param state (`named list`)\cr
    #'   this list should contain `subset` and `select` element where
    #'   each should be a named list containing values as a selection in the `FilterState`.
    #'   Names of each the `list` element in `subset` and `select` should correspond to
    #'   the name of the column in `rowData(data)` and `colData(data)`.
    #' @param ... ignored.
    #' @return `NULL`
    set_filter_state = function(data, state, ...) {
      checkmate::assert_class(data, "SummarizedExperiment")
      checkmate::assert_class(state, "list")

      checkmate::assert(
        checkmate::check_subset(names(state), c("subset", "select")),
        checkmate::check_class(state, "default_filter"),
        combine = "or"
      )
      checkmate::assert(
        checkmate::test_null(state$subset),
        checkmate::assert(
          checkmate::check_class(state$subset, "list"),
          checkmate::check_subset(names(state$subset), names(SummarizedExperiment::rowData(data))),
          combine = "and"
        ),
        combine = "or"
      )
      checkmate::assert(
        checkmate::test_null(state$select),
        checkmate::assert(
          checkmate::check_class(state$select, "list"),
          checkmate::check_subset(names(state$select), names(SummarizedExperiment::colData(data))),
          combine = "and"
        ),
        combine = "or"
      )

      filter_states <- self$state_list_get("subset")
      for (varname in names(state$subset)) {
        value <- resolve_state(state$subset[[varname]])
        if (varname %in% names(filter_states)) {
          fstate <- filter_states[[varname]]
          fstate$set_state(value)
        } else {
          fstate <- init_filter_state(
            SummarizedExperiment::rowData(data)[[varname]],
            varname = varname,
            dataname = private$dataname
          )
          fstate$set_state(value)
          self$state_list_push(
            x = fstate,
            state_list_index = "subset",
            state_id = varname
          )
        }
      }

      filter_states <- self$state_list_get("select")
      for (varname in names(state$select)) {
        value <- resolve_state(state$select[[varname]])
        if (varname %in% names(filter_states)) {
          fstate <- filter_states[[varname]]
          fstate$set_state(value)
        } else {
          fstate <- init_filter_state(
            SummarizedExperiment::colData(data)[[varname]],
            varname = varname,
            dataname = private$dataname
          )
          fstate$set_state(value)
          self$state_list_push(
            x = fstate,
            state_list_index = "select",
            state_id = varname
          )
        }
      }
      logger::log_trace(paste(
        "SEFilterState$set_filter_state initialized,",
        "dataname: { private$dataname }"
      ))
      NULL
    },

    #' @description Remove a variable from the `state_list` and its corresponding UI element.
    #'
    #' @param state_id (`character(1)`)\cr name of `state_list` element.
    #'
    #' @return `NULL`
    remove_filter_state = function(state_id) {
      logger::log_trace(
        sprintf(
          "%s$remove_filter_state called, dataname: %s",
          class(self)[1],
          private$dataname
        )
      )

      checkmate::assert(
        !checkmate::test_null(names(state_id)),
        checkmate::check_subset(names(state_id), c("subset", "select")),
        combine = "and"
      )
      for (varname in state_id$subset) {
        if (!all(unlist(state_id$subset) %in% names(self$state_list_get("subset")))) {
          warning(paste(
            "Variable:", state_id, "is not present in the actual active subset filters of dataset:",
            "{ private$dataname } therefore no changes are applied."
          ))
          logger::log_warn(
            paste(
              "Variable:", state_id, "is not present in the actual active subset filters of dataset:",
              "{ private$dataname } therefore no changes are applied."
            )
          )
        } else {
          self$state_list_remove(state_list_index = "subset", state_id = varname)
          logger::log_trace(
            sprintf(
              "%s$remove_filter_state for subset variable %s done, dataname: %s",
              class(self)[1],
              varname,
              private$dataname
            )
          )
        }
      }

      for (varname in state_id$select) {
        if (!all(unlist(state_id$select) %in% names(self$state_list_get("select")))) {
          warning(paste(
            "Variable:", state_id, "is not present in the actual active select filters of dataset:",
            "{ private$dataname } therefore no changes are applied."
          ))
          logger::log_warn(
            paste(
              "Variable:", state_id, "is not present in the actual active select filters of dataset:",
              "{ private$dataname } therefore no changes are applied."
            )
          )
        } else {
          self$state_list_remove(state_list_index = "select", state_id = varname)
          sprintf(
            "%s$remove_filter_state for select variable %s done, dataname: %s",
            class(self)[1],
            varname,
            private$dataname
          )
        }
      }
    },

    # shiny modules ----

    #' @description
    #' Shiny UI module to add filter variable
    #' @param id (`character(1)`)\cr
    #'  id of shiny module
    #' @param data (`SummarizedExperiment`)\cr
    #'  object containing `colData` and `rowData` which columns
    #'  are used to choose filter variables. Column selection from `colData`
    #'  and `rowData` are separate shiny entities.
    #' @return shiny.tag
    ui_add_filter_state = function(id, data) {
      checkmate::assert_string(id)
      stopifnot(is(data, "SummarizedExperiment"))

      ns <- NS(id)

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

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

      div(
        row_input,
        col_input
      )
    },

    #' @description
    #' Shiny server module to add filter variable
    #'
    #' Module controls available choices to select as a filter variable.
    #' Selected filter variable is being removed from available choices.
    #' Removed filter variable gets back to available choices.
    #' This module unlike other `FilterStates` classes manages two
    #' sets of filter variables - one for `colData` and another for
    #' `rowData`.
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param data (`SummarizedExperiment`)\cr
    #'  object containing `colData` and `rowData` which columns
    #'  are used to choose filter variables. Column selection from `colData`
    #'  and `rowData` are separate shiny entities.
    #' @param ... ignored
    #' @return `moduleServer` function which returns `NULL`
    srv_add_filter_state = function(id, data, ...) {
      stopifnot(is(data, "SummarizedExperiment"))
      check_ellipsis(..., stop = FALSE)
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace(
            "SEFilterState$srv_add_filter_state initializing, dataname: { private$dataname }"
          )
          shiny::setBookmarkExclude(c("row_to_add", "col_to_add"))
          active_filter_col_vars <- reactive({
            vapply(
              X = self$state_list_get(state_list_index = "select"),
              FUN.VALUE = character(1),
              FUN = function(x) x$get_varname()
            )
          })
          active_filter_row_vars <- reactive({
            vapply(
              X = self$state_list_get(state_list_index = "subset"),
              FUN.VALUE = character(1),
              FUN = function(x) x$get_varname()
            )
          })

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

          # available choices to display
          avail_row_data_choices <- reactive({
            choices <- setdiff(
              get_supported_filter_varnames(data = row_data),
              active_filter_row_vars()
            )

            data_choices_labeled(
              data = row_data,
              choices = choices,
              varlabels = character(0),
              keys = NULL
            )
          })
          avail_col_data_choices <- reactive({
            choices <- setdiff(
              get_supported_filter_varnames(data = col_data),
              active_filter_col_vars()
            )

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


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

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

          observeEvent(
            eventExpr = input$col_to_add,
            handlerExpr = {
              logger::log_trace(
                sprintf(
                  "SEFilterStates$srv_add_filter_state@3 adding FilterState of column %s to col data, dataname: %s",
                  deparse1(input$col_to_add),
                  private$dataname
                )
              )
              self$state_list_push(
                x = init_filter_state(
                  SummarizedExperiment::colData(data)[[input$col_to_add]],
                  varname = input$col_to_add,
                  dataname = private$dataname
                ),
                state_list_index = "select",
                state_id = input$col_to_add
              )
              logger::log_trace(
                sprintf(
                  "SEFilterStates$srv_add_filter_state@3 added FilterState of column %s to col data, dataname: %s",
                  deparse1(input$col_to_add),
                  private$dataname
                )
              )
            }
          )

          observeEvent(
            eventExpr = input$row_to_add,
            handlerExpr = {
              logger::log_trace(
                sprintf(
                  "SEFilterStates$srv_add_filter_state@4 adding FilterState of variable %s to row data, dataname: %s",
                  deparse1(input$row_to_add),
                  private$dataname
                )
              )
              self$state_list_push(
                x = init_filter_state(
                  SummarizedExperiment::rowData(data)[[input$row_to_add]],
                  varname = input$row_to_add,
                  dataname = private$dataname
                ),
                state_list_index = "subset",
                state_id = input$row_to_add
              )
              logger::log_trace(
                sprintf(
                  "SEFilterStates$srv_add_filter_state@4 added FilterState of variable %s to row data, dataname: %s",
                  deparse1(input$row_to_add),
                  private$dataname
                )
              )
            }
          )

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

#' @name FilteredData
#' @docType class
#'
#' @title Class to encapsulate filtered datasets
#'
#' @details
#' The main purpose of this class is to provide a collection of reactive datasets,
#' each dataset having a filter state that determines how it is filtered.
#'
#' For each dataset, `get_filter_expr` returns the call to filter the dataset according
#' to the filter state. The data itself can be obtained through `get_data`.
#'
#' The datasets are filtered lazily, i.e. only when requested / needed in a Shiny app.
#'
#' By design, any dataname set through `set_dataset` cannot be removed because
#' other code may already depend on it. As a workaround, the underlying
#' data can be set to `NULL`.
#'
#' The class currently supports variables of the following types within datasets:
#' - `choices`: variable of type `factor`, e.g. `ADSL$COUNTRY`, `iris$Species`
#'      zero or more options can be selected, when the variable is a factor
#' - `logical`: variable of type `logical`, e.g. `ADSL$TRT_FLAG`
#'      exactly one option must be selected, `TRUE` or `FALSE`
#' - `ranges`: variable of type `numeric`, e.g. `ADSL$AGE`, `iris$Sepal.Length`
#'      numerical range, a range within this range can be selected
#' - `dates`: variable of type `Date`, `POSIXlt`
#' Other variables cannot be used for filtering the data in this class.
#'
#' Common arguments are:
#' 1. `filtered`: whether to return a filtered result or not
#' 2. `dataname`: the name of one of the datasets in this `FilteredData`
#' 3. `varname`: one of the columns in a dataset
#'
#' @keywords internal
#'
#' @examples
#' library(shiny)
#' datasets <- teal.slice:::FilteredData$new(
#'   list(
#'     iris = list(dataset = iris),
#'     mtcars = list(dataset = mtcars, metadata = list(type = "training"))
#'   )
#' )
#'
#' # get datanames
#' datasets$datanames()
#'
#' df <- datasets$get_data("iris", filtered = FALSE)
#' print(df)
#'
#' datasets$get_metadata("mtcars")
#'
#' isolate(
#'   datasets$set_filter_state(
#'     list(iris = list(Species = list(selected = "virginica")))
#'   )
#' )
#' isolate(datasets$get_call("iris"))
#'
#' isolate(
#'   datasets$set_filter_state(
#'     list(mtcars = list(mpg = list(selected = c(15, 20))))
#'   )
#' )
#'
#' isolate(datasets$get_filter_state())
#' isolate(datasets$get_filter_overview("iris"))
#' isolate(datasets$get_filter_overview("mtcars"))
#' isolate(datasets$get_call("iris"))
#' isolate(datasets$get_call("mtcars"))
#'
FilteredData <- R6::R6Class( # nolint
  "FilteredData",
  ## __Public Methods ====
  public = list(
    #' @description
    #' Initialize a `FilteredData` object
    #' @param data_objects (`list`) should contain.
    #' - `dataset` data object object supported by [`FilteredDataset`].
    #' - `metatada` (optional) additional metadata attached to the `dataset`.
    #' - `keys` (optional) primary keys.
    #' - `datalabel` (optional) label describing the `dataset`.
    #' - `parent` (optional) which `NULL` is a parent of this one.
    #' @param join_keys (`JoinKeys` or NULL) see [`teal.data::join_keys()`].
    #' @param code (`CodeClass` or `NULL`) see [`teal.data::CodeClass`].
    #' @param check (`logical(1)`) whether data has been check against reproducibility.
    #'
    initialize = function(data_objects, join_keys = NULL, code = NULL, check = FALSE) {
      checkmate::assert_list(data_objects, any.missing = FALSE, min.len = 0, names = "unique")
      # Note the internals of data_objects are checked in set_dataset
      checkmate::assert_class(join_keys, "JoinKeys", null.ok = TRUE)
      checkmate::assert_class(code, "CodeClass", null.ok = TRUE)
      checkmate::assert_flag(check)

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

      for (dataname in names(data_objects)) {
        self$set_dataset(data_objects[[dataname]], dataname)
      }

      if (!is.null(join_keys)) {
        self$set_join_keys(join_keys)
      }

      invisible(self)
    },

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

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

    #' @description
    #' Gets dataset names of a given dataname for the filtering.
    #'
    #' @param dataname (`character` vector) names of the dataset
    #'
    #' @return (`character` vector) of dataset names
    #'
    get_filterable_datanames = function(dataname) {
      dataname
    },

    #' @description
    #' Gets variable names of a given dataname for the filtering.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #'
    #' @return (`character` vector) of variable names
    #'
    get_filterable_varnames = function(dataname) {
      self$get_filtered_dataset(dataname)$get_filterable_varnames()
    },

    #' @description
    #' Set the variable names of a given dataset for the filtering.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @param varnames (`character` or `NULL`)
    #'   variables which users can choose to filter the data;
    #'   see `self$get_filterable_varnames` for more details
    #'
    #' @return this `FilteredData` object invisibly
    #'
    set_filterable_varnames = function(dataname, varnames) {
      private$check_data_varname_exists(dataname)
      self$get_filtered_dataset(dataname)$set_filterable_varnames(varnames)
      invisible(self)
    },

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

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

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

    #' @description
    #' Gets filtered or unfiltered dataset.
    #'
    #' For `filtered = FALSE`, the original data set with
    #' `set_data` is returned including all attributes.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @param filtered (`logical`) whether to return a filtered or unfiltered dataset
    #'
    get_data = function(dataname, filtered = TRUE) {
      private$check_data_varname_exists(dataname)
      checkmate::assert_flag(filtered)
      if (filtered) {
        # This try is specific for MAEFilteredDataset due to a bug in
        # S4Vectors causing errors when using the subset function on MAE objects.
        # The fix was introduced in S4Vectors 0.30.1, but is unavailable for R versions < 4.1
        # Link to the issue: https://github.com/insightsengineering/teal/issues/210
        tryCatch(
          private$reactive_data[[dataname]](),
          error = function(error) {
            shiny::validate(paste(
              "Filtering expression returned error(s). Please change filters.\nThe error message was:",
              error$message,
              sep = "\n"
            ))
          }
        )
      } else {
        self$get_filtered_dataset(dataname)$get_dataset()
      }
    },

    #' @description
    #' Returns whether the datasets in the object has undergone a reproducibility check.
    #'
    #' @return `logical`
    #'
    get_check = function() {
      private$.check
    },

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

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

    #' @description
    #' Get filter overview table in form of X (filtered) / Y (non-filtered).
    #'
    #' This is intended to be presented in the application.
    #' The content for each of the data names is defined in `get_filter_overview_info` method.
    #'
    #' @param datanames (`character` vector) names of the dataset
    #'
    #' @return (`matrix`) matrix of observations and subjects of all datasets
    #'
    get_filter_overview = function(datanames) {
      if (identical(datanames, "all")) {
        datanames <- self$datanames()
      }
      check_in_subset(datanames, self$datanames(), "Some datasets are not available: ")

      rows <- lapply(
        datanames,
        function(dataname) {
          self$get_filtered_dataset(dataname)$get_filter_overview_info(
            filtered_dataset = self$get_data(dataname = dataname, filtered = TRUE)
          )
        }
      )

      do.call(rbind, rows)
    },

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

    #' @description
    #' Gets labels of variables in the data.
    #'
    #' Variables are the column names of the data.
    #' Either, all labels must have been provided for all variables
    #' in `set_data` or `NULL`.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @param variables (`character`) variables to get labels for;
    #'   if `NULL`, for all variables in data
    #'
    #' @return (`character` or `NULL`) variable labels, `NULL` if `column_labels`
    #'   attribute does not exist for the data
    #'
    get_varlabels = function(dataname, variables = NULL) {
      self$get_filtered_dataset(dataname)$get_varlabels(variables = variables)
    },

    #' @description
    #' Gets variable names.
    #'
    #' @param dataname (`character`) the name of the dataset
    #'
    #' @return (`character` vector) of variable names
    #'
    get_varnames = function(dataname) {
      self$get_filtered_dataset(dataname)$get_varnames()
    },

    #' @description
    #' When active_datanames is "all", sets them to all `datanames`,
    #' otherwise, it makes sure that it is a subset of the available `datanames`.
    #'
    #' @param datanames `character vector` datanames to pick
    #'
    #' @return the intersection of `self$datanames()` and `datanames`
    #'
    handle_active_datanames = function(datanames) {
      logger::log_trace("FilteredData$handle_active_datanames handling { paste(datanames, collapse = \" \") }")
      if (identical(datanames, "all")) {
        datanames <- self$datanames()
      } else {
        for (dataname in datanames) {
          tryCatch(
            check_in_subset(datanames, self$datanames(), "Some datasets are not available: "),
            error = function(e) {
              message(e$message)
            }
          )
        }
      }
      datanames <- self$get_filterable_datanames(datanames)
      intersect(self$datanames(), datanames)
    },

    #' @description
    #' Adds a dataset to this `FilteredData`.
    #'
    #' @details
    #' `set_dataset` creates a `FilteredDataset` object which keeps
    #' `dataset` for the filtering purpose.
    #'
    #' @param dataset_args (`list`)\cr
    #'   containing the arguments except (`dataname`)
    #'   needed by `init_filtered_dataset`
    #' @param dataname (`string`)\cr
    #'   the name of the `dataset` to be added to this object
    #'
    #' @return (`self`) invisibly this `FilteredData`
    #'
    set_dataset = function(dataset_args, dataname) {
      logger::log_trace("FilteredData$set_dataset setting dataset, name: { dataname }")
      validate_dataset_args(dataset_args, dataname)

      dataset <- dataset_args$dataset
      dataset_args$dataset <- NULL

      # to include it nicely in the Show R Code;
      # the UI also uses datanames in ids, so no whitespaces allowed
      check_simple_name(dataname)
      private$filtered_datasets[[dataname]] <- do.call(
        what = init_filtered_dataset,
        args = c(list(dataset), dataset_args, list(dataname = dataname))
      )

      private$reactive_data[[dataname]] <- reactive({
        env <- new.env(parent = parent.env(globalenv()))
        env[[dataname]] <- self$get_filtered_dataset(dataname)$get_dataset()
        filter_call <- self$get_call(dataname)
        eval_expr_with_msg(filter_call, env)
        get(x = dataname, envir = env)
      })

      invisible(self)
    },

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

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

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

    # Functions useful for restoring from another dataset ----
    #' @description
    #' Gets the reactive values from the active `FilterState` objects.
    #'
    #' Gets all active filters in the form of a nested list.
    #' The output list is a compatible input to `self$set_filter_state`.
    #' The attribute `formatted` renders the output of `self$get_formatted_filter_state`,
    #' which is a character formatting of the filter state.
    #'
    #' @return `named list` with elements corresponding to `FilteredDataset` objects
    #' with active filters. In addition, the `formatted` attribute holds
    #' the character format of the active filter states.
    #'
    get_filter_state = function() {
      states <- lapply(self$get_filtered_dataset(), function(x) x$get_filter_state())
      filtered_states <- Filter(function(x) length(x) > 0, states)
      structure(filtered_states, formatted = self$get_formatted_filter_state())
    },

    #' @description
    #' Returns the filter state formatted for printing to an `IO` device.
    #'
    #' @return `character` the pre-formatted filter state
    #'
    #' @examples
    #' utils::data(miniACC, package = "MultiAssayExperiment")
    #' datasets <- teal.slice:::FilteredData$new(
    #'   list(iris = list(dataset = iris),
    #'        mae = list(dataset = miniACC)
    #'   ),
    #'   join_keys = NULL
    #' )
    #' fs <- list(
    #'   iris = list(
    #'     Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE),
    #'     Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE)
    #'   ),
    #'   mae = list(
    #'     subjects = list(
    #'       years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE),
    #'       vital_status = list(selected = "1", keep_na = FALSE),
    #'       gender = list(selected = "female", keep_na = TRUE)
    #'     ),
    #'     RPPAArray = list(
    #'       subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE))
    #'     )
    #'   )
    #' )
    #' isolate(datasets$set_filter_state(state = fs))
    #' cat(shiny::isolate(datasets$get_formatted_filter_state()))
    #'
    get_formatted_filter_state = function() {
      out <-
        unlist(sapply(
          self$get_filtered_dataset(),
          function(filtered_dataset) {
            filtered_dataset$get_formatted_filter_state()
          }
        ))
      paste(out, collapse = "\n")
    },

    #' @description
    #' Sets active filter states.
    #'
    #' @param state (`named list`)\cr
    #'  nested list of filter selections applied to datasets
    #'
    #' @return `NULL`
    #'
    #' @examples
    #' utils::data(miniACC, package = "MultiAssayExperiment")
    #'
    #' datasets <- teal.slice:::FilteredData$new(
    #'   list(iris = list(dataset = iris),
    #'        mae = list(dataset = miniACC)
    #'   ),
    #'   join_keys = NULL
    #' )
    #' fs <- list(
    #'   iris = list(
    #'     Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE),
    #'     Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE)
    #'   ),
    #'   mae = list(
    #'     subjects = list(
    #'       years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE),
    #'       vital_status = list(selected = "1", keep_na = FALSE),
    #'       gender = list(selected = "female", keep_na = TRUE)
    #'     ),
    #'     RPPAArray = list(
    #'       subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE))
    #'     )
    #'   )
    #' )
    #' shiny::isolate(datasets$set_filter_state(state = fs))
    #' shiny::isolate(datasets$get_filter_state())
    #'
    set_filter_state = function(state) {
      checkmate::assert_subset(names(state), self$datanames())
      logger::log_trace(
        "FilteredData$set_filter_state initializing, dataname: { paste(names(state), collapse = ' ') }"
      )
      for (dataname in names(state)) {
        fdataset <- self$get_filtered_dataset(dataname = dataname)
        dataset_state <- state[[dataname]]

        fdataset$set_filter_state(
          state = dataset_state,
          vars_include = self$get_filterable_varnames(dataname)
        )
      }
      logger::log_trace(
        "FilteredData$set_filter_state initialized, dataname: { paste(names(state), collapse = ' ') }"
      )

      invisible(NULL)
    },

    #' @description
    #' Removes one or more `FilterState` of a `FilteredDataset` in a `FilteredData` object.
    #'
    #' @param state (`named list`)\cr
    #'  nested list of filter selections applied to datasets
    #'
    #' @return `NULL` invisibly
    #'
    remove_filter_state = function(state) {
      checkmate::assert_subset(names(state), self$datanames())

      logger::log_trace(
        "FilteredData$remove_filter_state called, dataname: { paste(names(state), collapse = ' ') }"
      )

      for (dataname in names(state)) {
        fdataset <- self$get_filtered_dataset(dataname = dataname)
        fdataset$remove_filter_state(state_id = state[[dataname]])
      }

      logger::log_trace(
        "FilteredData$remove_filter_state done, dataname: { paste(names(state), collapse = ' ') }"
      )

      invisible(NULL)
    },

    #' @description
    #' Remove all `FilterStates` of a `FilteredDataset` or all `FilterStates`
    #' of a `FilteredData` object.
    #'
    #' @param datanames (`character`)\cr
    #'   datanames to remove their `FilterStates` or empty which removes
    #'   all `FilterStates` in the `FilteredData` object
    #'
    #' @return `NULL` invisibly
    #'
    remove_all_filter_states = function(datanames = self$datanames()) {
      logger::log_trace(
        "FilteredData$remove_all_filter_states called, datanames: { paste(datanames, collapse = ', ') }"
      )

      for (dataname in datanames) {
        fdataset <- self$get_filtered_dataset(dataname = dataname)
        fdataset$state_lists_empty()
      }

      logger::log_trace(
        paste(
          "FilteredData$remove_all_filter_states removed all FilterStates,",
          "datanames: { paste(datanames, collapse = ', ') }"
        )
      )

      invisible(NULL)
    },

    #' @description
    #' Sets this object from a bookmarked state.
    #'
    #' Only sets the filter state, does not set the data
    #' and the preprocessing code. The data should already have been set.
    #' Also checks the preprocessing code is identical if provided in the `state`.
    #'
    #' Since this function is used from the end-user part, its error messages
    #' are more verbose. We don't call the Shiny modals from here because this
    #' class may be used outside of a Shiny app.
    #'
    #' @param state (`named list`)\cr
    #'   containing fields `data_hash`, `filter_states` and `preproc_code`
    #' @param check_data_hash (`logical`) whether to check that `md5sums` agree
    #'   for the data; may not make sense with randomly generated data per session
    #'
    restore_state_from_bookmark = function(state, check_data_hash = TRUE) {
      stop("Pure virtual method")
    },

    #' @description
    #' Disable the filter panel by adding `disable` class to `filter_add_vars`
    #' and `filter_panel_active_vars` tags in the User Interface.
    #' In addition, it will store the existing filter states in a private field called `cached_states`
    #' before removing all filter states from the object.
    #'
    filter_panel_disable = function() {
      private$filter_panel_active <- FALSE
      shinyjs::disable("filter_add_vars")
      shinyjs::disable("filter_active_vars")
      private$cached_states <- self$get_filter_state()
      self$remove_all_filter_states()
      invisible(NULL)
    },

    #' @description enable the filter panel
    #' Enable the filter panel by adding `enable` class to `filter_add_vars`
    #' and `filter_active_vars` tags in the User Interface.
    #' In addition, it will restore the filter states from a private field called `cached_states`.
    #'
    filter_panel_enable = function() {
      private$filter_panel_active <- TRUE
      shinyjs::enable("filter_add_vars")
      shinyjs::enable("filter_active_vars")
      if (length(private$cached_states) && (length(self$get_filter_state()) == 0)) {
        self$set_filter_state(private$cached_states)
      }
      invisible(NULL)
    },

    #' @description
    #' Gets the state of filter panel, if activated.
    #'
    get_filter_panel_active = function() {
      private$filter_panel_active
    },

    #' @description
    #' Gets the id of the filter panel UI.
    get_filter_panel_ui_id = function() {
      private$filter_panel_ui_id
    },

    # shiny modules -----

    #' Module for the right filter panel in the teal app
    #' with a filter overview panel and a filter variable panel.
    #'
    #' This panel contains info about the number of observations left in
    #' the (active) datasets and allows to filter the datasets.
    #'
    #' @param id (`character(1)`)\cr
    #'   module id
    ui_filter_panel = function(id) {
      ns <- NS(id)
      div(
        id = ns(NULL), # used for hiding / showing
        include_css_files(pattern = "filter-panel"),
        div(
          id = ns("switch-button"),
          class = "flex justify-content-right",
          div(
            title = "Enable/Disable filtering",
            shinyWidgets::prettySwitch(
              ns("filter_panel_active"),
              label = "",
              status = "success",
              fill = TRUE,
              value = TRUE,
              inline = FALSE,
              width = 30
            )
          )
        ),
        div(
          id = ns("filters_overview"), # not used, can be used to customize CSS behavior
          class = "well",
          tags$div(
            class = "row",
            tags$div(
              class = "col-sm-9",
              tags$label("Active Filter Summary", class = "text-primary mb-4")
            ),
            tags$div(
              class = "col-sm-3",
              actionLink(
                ns("minimise_filter_overview"),
                label = NULL,
                icon = icon("angle-down", lib = "font-awesome"),
                title = "Minimise panel",
                class = "remove pull-right"
              )
            )
          ),
          tags$br(),
          div(
            id = ns("filters_overview_contents"),
            self$ui_filter_overview(ns("teal_filters_info"))
          )
        ),
        div(
          id = ns("filter_active_vars"), # not used, can be used to customize CSS behavior
          class = "well",
          tags$div(
            class = "row",
            tags$div(
              class = "col-sm-6",
              tags$label("Active Filter Variables", class = "text-primary mb-4")
            ),
            tags$div(
              class = "col-sm-6",
              actionLink(
                ns("remove_all_filters"),
                label = "",
                icon("circle-xmark", lib = "font-awesome"),
                title = "Remove active filters",
                class = "remove_all pull-right"
              ),
              actionLink(
                ns("minimise_filter_active"),
                label = NULL,
                icon = icon("angle-down", lib = "font-awesome"),
                title = "Minimise panel",
                class = "remove pull-right"
              )
            )
          ),
          div(
            id = ns("filter_active_vars_contents"),
            tagList(
              lapply(
                self$datanames(),
                function(dataname) {
                  fdataset <- self$get_filtered_dataset(dataname)
                  fdataset$ui(id = ns(private$get_ui_id(dataname)))
                }
              )
            )
          ),
          shinyjs::hidden(
            div(
              id = ns("filters_active_count"),
              textOutput(ns("teal_filters_count"))
            )
          )
        ),
        div(
          id = ns("filter_add_vars"), # not used, can be used to customize CSS behavior
          class = "well",
          tags$div(
            class = "row",
            tags$div(
              class = "col-sm-9",
              tags$label("Add Filter Variables", class = "text-primary mb-4")
            ),
            tags$div(
              class = "col-sm-3",
              actionLink(
                ns("minimise_filter_add_vars"),
                label = NULL,
                icon = icon("angle-down", lib = "font-awesome"),
                title = "Minimise panel",
                class = "remove pull-right"
              )
            )
          ),
          div(
            id = ns("filter_add_vars_contents"),
            tagList(
              lapply(
                self$datanames(),
                function(dataname) {
                  fdataset <- self$get_filtered_dataset(dataname)
                  id <- ns(private$get_ui_add_filter_id(dataname))
                  # add span with same id to show / hide
                  return(
                    span(
                      id = id,
                      fdataset$ui_add_filter_state(id)
                    )
                  )
                }
              )
            )
          )
        )
      )
    },

    #' Server function for filter panel
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param active_datanames `function / reactive` returning datanames that
    #'   should be shown on the filter panel,
    #'   must be a subset of the `datanames` argument provided to `ui_filter_panel`;
    #'   if the function returns `NULL` (as opposed to `character(0)`), the filter
    #'   panel will be hidden
    #' @return `moduleServer` function which returns `NULL`
    srv_filter_panel = function(id, active_datanames = function() "all") {
      stopifnot(
        is.function(active_datanames) || is.reactive(active_datanames)
      )
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilteredData$srv_filter_panel initializing")
          shiny::setBookmarkExclude("remove_all_filters")
          self$srv_filter_overview(
            id = "teal_filters_info",
            active_datanames = active_datanames
          )

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

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

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

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

          # use isolate because we assume that the number of datasets does not change
          # over the course of the teal app
          # alternatively, one can proceed as in modules_filter_items to dynamically insert, remove UIs
          isol_datanames <- isolate(self$datanames()) # they are already ordered
          # should not use for-loop as variables are otherwise only bound by reference
          # and last dataname would be used
          lapply(
            isol_datanames,
            function(dataname) {
              fdataset <- self$get_filtered_dataset(dataname)
              fdataset$server(id = private$get_ui_id(dataname))
            }
          )

          lapply(
            isol_datanames,
            function(dataname) {
              fdataset <- self$get_filtered_dataset(dataname)
              fdataset$srv_add_filter_state(
                id = private$get_ui_add_filter_id(dataname),
                vars_include = self$get_filterable_varnames(dataname)
              )
            }
          )

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

          private$filter_panel_ui_id <- session$ns(NULL)
          observeEvent(
            eventExpr = input$filter_panel_active,
            handlerExpr = {
              if (isTRUE(input$filter_panel_active)) {
                self$filter_panel_enable()
                logger::log_trace("Enable the Filtered Panel with the filter_panel_enable method")
              } else {
                self$filter_panel_disable()
                logger::log_trace("Disable the Filtered Panel with the filter_panel_enable method")
              }
            }, ignoreNULL = TRUE
          )

          observeEvent(
            eventExpr = active_datanames(),
            handlerExpr = {
              private$hide_inactive_datasets(active_datanames)
            },
            priority = 1
          )

          observeEvent(input$remove_all_filters, {
            logger::log_trace("FilteredData$srv_filter_panel@1 removing all filters")
            lapply(self$datanames(), function(dataname) {
              fdataset <- self$get_filtered_dataset(dataname = dataname)
              fdataset$state_lists_empty()
            })
            logger::log_trace("FilteredData$srv_filter_panel@1 removed all filters")
          })

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

    #' Creates the UI for the module showing counts for each dataset
    #' contrasting the filtered to the full unfiltered dataset
    #'
    #' Per dataset, it displays
    #' the number of rows/observations in each dataset,
    #' the number of unique subjects.
    #'
    #' @param id module id
    ui_filter_overview = function(id) {
      ns <- NS(id)

      div(
        class = "teal_active_summary_filter_panel",
        tableOutput(ns("table"))
      )
    },

    #' Server function to display the number of records in the filtered and unfiltered
    #' data
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param active_datanames (`function`, `reactive`)\cr
    #'   returning datanames that should be shown on the filter panel,
    #'   must be a subset of the `datanames` argument provided to `ui_filter_panel`;
    #'   if the function returns `NULL` (as opposed to `character(0)`), the filter
    #'   panel will be hidden.
    #' @return `moduleServer` function which returns `NULL`
    srv_filter_overview = function(id, active_datanames = function() "all") {
      stopifnot(
        is.function(active_datanames) || is.reactive(active_datanames)
      )
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("FilteredData$srv_filter_overview initializing")
          output$table <- renderUI({
            logger::log_trace("FilteredData$srv_filter_overview@1 updating counts")
            datanames <- if (identical(active_datanames(), "all")) {
              self$datanames()
            } else {
              active_datanames()
            }

            if (length(datanames) == 0) {
              return(NULL)
            }

            datasets_df <- self$get_filter_overview(datanames = datanames)

            body_html <- lapply(
              seq_len(nrow(datasets_df)),
              function(x) {
                tags$tr(
                  tags$td(rownames(datasets_df)[x]),
                  tags$td(datasets_df[x, 1]),
                  tags$td(datasets_df[x, 2])
                )
              }
            )

            header_html <- tags$tr(
              tags$td(""),
              tags$td(colnames(datasets_df)[1]),
              tags$td(colnames(datasets_df)[2])
            )

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

          shiny::outputOptions(output, "table", suspendWhenHidden = FALSE)
          logger::log_trace("FilteredData$srv_filter_overview initialized")
          NULL
        }
      )
    }
  ),

  ## __Private Methods ====
  private = list(
    # selectively hide / show to only show `active_datanames` out of all datanames
    hide_inactive_datasets = function(active_datanames) {
      lapply(
        self$datanames(),
        function(dataname) {
          id_add_filter <- private$get_ui_add_filter_id(dataname)
          id_filter_dataname <- private$get_ui_id(dataname)

          if (dataname %in% active_datanames()) {
            # shinyjs takes care of the namespace around the id
            shinyjs::show(id_add_filter)
            shinyjs::show(id_filter_dataname)
          } else {
            shinyjs::hide(id_add_filter)
            shinyjs::hide(id_filter_dataname)
          }
        }
      )
    },

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

    # activate/deactivate filter panel
    filter_panel_active = TRUE,

    # filter panel ui id
    filter_panel_ui_id = character(0),

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

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

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

    # reactive i.e. filtered data
    reactive_data = list(),
    cached_states = NULL,

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

    # @details
    # Composes id for the FilteredDataset shiny element (active filter vars)
    # @param dataname (`character(1)`) name of the dataset which ui is composed for.
    # @return `character(1)` - `<dataname>_filter`
    get_ui_id = function(dataname) {
      sprintf("%s_filter", dataname)
    },

    # @details
    # Composes id for the FilteredDataset shiny element (add filter state)
    # @param dataname (`character(1)`)  name of the dataset which ui is composed for.
    # @return `character(1)` - `<dataname>_filter`
    get_ui_add_filter_id = function(dataname) {
      sprintf("add_%s_filter", dataname)
    },

    # @details
    # Validates the state of this FilteredData.
    # The call to this function should be isolated to avoid a reactive dependency.
    # Getting the names of a reactivevalues also needs a reactive context.
    validate = function() {
      # Note: Here, we directly refer to the private attributes because the goal of this
      # function is to check the underlying attributes and the get / set functions might be corrupted

      has_same_names <- function(x, y) setequal(names(x), names(y))
      # check `filter_states` are all valid
      lapply(
        names(private$filter_states),
        function(dataname) {
          stopifnot(is.list(private$filter_states)) # non-NULL, possibly empty list
          lapply(
            names(private$filter_states[[dataname]]),
            function(varname) {
              var_state <- private$filter_states[[dataname]][[varname]]
              stopifnot(!is.null(var_state)) # should not be NULL, see doc of this attribute
              check_valid_filter_state(
                filter_state = var_state,
                dataname = dataname,
                varname = varname
              )
            }
          )
        }
      )

      return(invisible(NULL))
    },

    # @description
    # Checks if the dataname exists and
    # (if provided) that varname is a valid column in the dataset
    #
    # Stops when this is not the case.
    #
    # @param dataname (`character`) name of the dataset
    # @param varname (`character`) column within the dataset;
    #   if `NULL`, this check is not performed
    check_data_varname_exists = function(dataname, varname = NULL) {
      checkmate::assert_string(dataname)
      checkmate::assert_string(varname, null.ok = TRUE)

      isolate({
        # we isolate everything because we don't want to trigger again when datanames
        # change (which also triggers when any of the data changes)
        if (!dataname %in% names(self$get_filtered_dataset())) {
          # data must be set already
          stop(paste("data", dataname, "is not available"))
        }
        if (!is.null(varname) && !(varname %in% self$get_varnames(dataname = dataname))) {
          stop(paste("variable", varname, "is not in data", dataname))
        }
      })

      return(invisible(NULL))
    },

    # @description
    # Gets the number of active `FilterState` objects in all `FilterStates`
    # in all `FilteredDataset`s in this `FilteredData` object.
    # @return `integer(1)`
    get_filter_count = function() {
      sum(vapply(self$datanames(), function(dataname) {
        self$get_filtered_dataset(dataname)$get_filter_count()
      }, numeric(1L)))
    }
  )
)

# Wrapper functions for `FilteredData` class ----


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

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

#' Initializes `FilterState`
#'
#' Initializes `FilterState` depending on a variable class.\cr
#' @param x (`vector`)\cr
#'   values of the variable used in filter
#'
#' @param varname (`character(1)`)\cr
#'   name of the variable.
#'
#' @param varlabel (`character(0)`, `character(1)` or `NULL`)\cr
#'   label of the variable (optional).
#'
#' @param dataname (`character(1)`)\cr
#'   optional name of dataset where `x` is taken from. Must be specified
#'   if `extract_type` argument is not empty.
#'
#' @param extract_type (`character(0)`, `character(1)`)\cr
#' whether condition calls should be prefixed by dataname. Possible values:
#' \itemize{
#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
#' }
#' @keywords internal
#'
#' @examples
#' filter_state <- teal.slice:::RangeFilterState$new(
#'   c(1:10, NA, Inf),
#'   varname = "x",
#'   varlabel = "Pretty name",
#'   dataname = "dataname",
#'   extract_type = "matrix"
#' )
#'
#' filter_state$get_varname()
#' filter_state$get_varlabel()
#' isolate(filter_state$get_call())
#' \dontrun{
#' shinyApp(
#'   ui = fluidPage(
#'     isolate(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")
#'     )
#'   }
#' )
#' }
#' @return `FilterState` object
init_filter_state <- function(x,
                              varname,
                              varlabel = attr(x, "label"),
                              dataname = NULL,
                              extract_type = character(0)) {
  checkmate::assert_string(varname)
  checkmate::assert_character(varlabel, max.len = 1L, any.missing = FALSE, null.ok = TRUE)
  checkmate::assert_string(dataname, null.ok = TRUE)
  checkmate::assert_character(extract_type, max.len = 1L, any.missing = FALSE)
  if (length(extract_type) == 1) {
    checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
  }
  if (length(extract_type) == 1 && is.null(dataname)) {
    stop("if extract_type is specified, dataname must also be specified")
  }

  if (is.null(varlabel)) varlabel <- character(0L)

  if (all(is.na(x))) {
    return(
      EmptyFilterState$new(
        x = x,
        varname = varname,
        varlabel = varlabel,
        dataname = dataname,
        extract_type = extract_type
      )
    )
  }
  UseMethod("init_filter_state")
}

#' @keywords internal
#' @export
init_filter_state.default <- function(x,
                                      varname,
                                      varlabel = attr(x, "label"),
                                      dataname = NULL,
                                      extract_type = character(0)) {
  if (is.null(varlabel)) varlabel <- character(0)
  FilterState$new(
    x = x,
    varname = varname,
    varlabel = varlabel,
    dataname = dataname,
    extract_type = extract_type
  )
}

#' @keywords internal
#' @export
init_filter_state.logical <- function(x,
                                      varname,
                                      varlabel = attr(x, "label"),
                                      dataname = NULL,
                                      extract_type = character(0)) {
  if (is.null(varlabel)) varlabel <- character(0)
  LogicalFilterState$new(
    x = x,
    varname = varname,
    varlabel = varlabel,
    dataname = dataname,
    extract_type = extract_type
  )
}

#' @keywords internal
#' @export
init_filter_state.numeric <- function(x,
                                      varname,
                                      varlabel = attr(x, "label"),
                                      dataname = NULL,
                                      extract_type = character(0)) {
  if (is.null(varlabel)) varlabel <- character(0)
  if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
    ChoicesFilterState$new(
      x = x,
      varname = varname,
      varlabel = varlabel,
      dataname = dataname,
      extract_type = extract_type
    )
  } else {
    RangeFilterState$new(
      x = x,
      varname = varname,
      varlabel = varlabel,
      dataname = dataname,
      extract_type = extract_type
    )
  }
}

#' @keywords internal
#' @export
init_filter_state.factor <- function(x,
                                     varname,
                                     varlabel = attr(x, "label"),
                                     dataname = NULL,
                                     extract_type = character(0)) {
  if (is.null(varlabel)) varlabel <- character(0)
  ChoicesFilterState$new(
    x = x,
    varname = varname,
    varlabel = varlabel,
    dataname = dataname,
    extract_type = extract_type
  )
}

#' @keywords internal
#' @export
init_filter_state.character <- function(x,
                                        varname,
                                        varlabel = attr(x, "label"),
                                        dataname = NULL,
                                        extract_type = character(0)) {
  if (is.null(varlabel)) varlabel <- character(0)
  ChoicesFilterState$new(
    x = x,
    varname = varname,
    varlabel = varlabel,
    dataname = dataname,
    extract_type = extract_type
  )
}

#' @keywords internal
#' @export
init_filter_state.Date <- function(x,
                                   varname,
                                   varlabel = attr(x, "label"),
                                   dataname = NULL,
                                   extract_type = character(0)) {
  if (is.null(varlabel)) varlabel <- character(0)
  if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
    ChoicesFilterState$new(
      x = x,
      varname = varname,
      varlabel = varlabel,
      dataname = dataname,
      extract_type = extract_type
    )
  } else {
    DateFilterState$new(
      x = x,
      varname = varname,
      varlabel = varlabel,
      dataname = dataname,
      extract_type = extract_type
    )
  }
}

#' @keywords internal
#' @export
init_filter_state.POSIXct <- function(x,
                                      varname,
                                      varlabel = attr(x, "label"),
                                      dataname = NULL,
                                      extract_type = character(0)) {
  if (is.null(varlabel)) varlabel <- character(0)
  if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
    ChoicesFilterState$new(
      x = x,
      varname = varname,
      varlabel = varlabel,
      dataname = dataname,
      extract_type = extract_type
    )
  } else {
    DatetimeFilterState$new(
      x = x,
      varname = varname,
      varlabel = varlabel,
      dataname = dataname,
      extract_type = extract_type
    )
  }
}

#' @keywords internal
#' @export
init_filter_state.POSIXlt <- function(x,
                                      varname,
                                      varlabel = attr(x, "label"),
                                      dataname = NULL,
                                      extract_type = character(0)) {
  if (is.null(varlabel)) varlabel <- character(0)
  if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
    ChoicesFilterState$new(
      x = x,
      varname = varname,
      varlabel = varlabel,
      dataname = dataname,
      extract_type = extract_type
    )
  } else {
    DatetimeFilterState$new(
      x = x,
      varname = varname,
      varlabel = varlabel,
      dataname = dataname,
      extract_type = extract_type
    )
  }
}

#' Check that a given range is valid
#'
#' @param subinterval (`numeric` or `date`)\cr vector of length 2 to be compared against the full range.
#' @param range (`numeric` or `date`)\cr vector of length 2 containing the full range to validate against.
#' @param pre_msg `character` message to print before error for additional context.
#'
#' @return `NULL` if `subinterval` is a valid range or error with message otherwise.
#' @keywords internal
#'
#' @examples
#' \dontrun{
#' check_in_range(c(3, 1), c(1, 3))
#' check_in_range(c(0, 3), c(1, 3))
#' check_in_range(
#'   c(as.Date("2020-01-01"), as.Date("2020-01-20")),
#'   c(as.Date("2020-01-01"), as.Date("2020-01-02"))
#' )
#' }
check_in_range <- function(subinterval, range, pre_msg = "") {
  epsilon <- .Machine$double.eps^0.5 # needed for floating point arithmetic; same value as in base::all.equal()
  if ((length(subinterval) != 2)) {
    stop(
      sprintf(
        "%s range length should be 2 while it is %s",
        pre_msg,
        length(subinterval)
      )
    )
  }
  if (subinterval[[2]] + epsilon < subinterval[[1]]) {
    stop(sprintf(
      "%s unexpected: the upper bound of the range lower than the lower bound \n %s < %s",
      pre_msg,
      subinterval[[2]],
      subinterval[[1]]
    ))
  }

  if ((subinterval[[1]] + epsilon < range[[1]]) || (subinterval[[2]] - epsilon > range[[2]])) {
    stop(
      sprintf(
        "%s range (%s) not valid for full range (%s)",
        pre_msg, toString(subinterval), toString(range)
      )
    )
  }
}

#' Check that one set is a subset of another
#'
#' Raises an error message if not and says which elements are not in the allowed `choices`.
#'
#' @param subset `collection-like` should be a subset of the second argument `choices`
#' @param choices `collection-like` superset
#' @param pre_msg `character` message to print before error should there be any errors
#' @keywords internal
#'
#' @examples
#' \dontrun{
#' check_in_subset <- check_in_subset
#' check_in_subset(c("a", "b"), c("a", "b", "c"))
#' \dontrun{
#' check_in_subset(c("a", "b"), c("b", "c"), pre_msg = "Error: ")
#' # truncated because too long
#' check_in_subset("a", LETTERS, pre_msg = "Error: ")
#' }
#' }
check_in_subset <- function(subset, choices, pre_msg = "") {
  checkmate::assert_string(pre_msg)

  subset <- unique(subset)
  choices <- unique(choices)

  if (any(!(subset %in% choices))) {
    stop(paste0(
      pre_msg,
      "(", toString(subset[!(subset %in% choices)], width = 30), ")",
      " not in valid choices ",
      "(", toString(choices, width = 30), ")"
    ), call. = FALSE)
  }
  return(invisible(NULL))
}

#' Find containing limits for interval.
#'
#' Given an interval and a numeric vector,
#' find the smallest interval within the numeric vector that contains the interval.
#'
#' This is a helper function for `RangeFilterState` that modifies slider selection
#' so that the _subsetting call_ includes the value specified by the filter API call.
#'
#' Regardless of the underlying numeric data, the slider always presents 100 steps.
#' The ticks on the slider do not represent actual observations but rather borders between virtual bins.
#' Since the value selected on the slider is passed to `private$selected` and that in turn
#' updates the slider selection, programmatic selection of arbitrary values may inadvertently shift
#' the selection to the closest tick, thereby dropping the actual value set (if it exists in the data).
#'
#' This function purposely shifts the selection to the closest ticks whose values form an interval
#' that will contain the interval defined by the filter API call.
#'
#' @param x `numeric(2)` interval to contain
#' @param range `numeric(>=2)` vector of values to contain `x` in
#'
#' @return Numeric vector of length 2 that lies within `range`.
#'
#' @keywords internal
#'
#' @examples
#' \dontrun{
#' ticks <- 1:10
#' values1 <- c(3, 5)
#' contain_interval(values1, ticks)
#' values2 <- c(3.1, 5.7)
#' contain_interval(values2, ticks)
#' values3 <- c(0, 20)
#' contain_interval(values3, ticks)
#'}
contain_interval <- function(x, range) {
  checkmate::assert_numeric(x, len = 2L, any.missing = FALSE, sorted = TRUE)
  checkmate::assert_numeric(range, min.len = 2L, any.missing = FALSE, sorted = TRUE)

  x[1] <- Find(function(i) i <= x[1], range, nomatch = min(range), right = TRUE)
  x[2] <- Find(function(i) i >= x[2], range, nomatch = max(range))
  x
}

#' @title `FilterStates` R6 class
#'
#' @description
#' Abstract class that manages adding and removing `FilterState` objects
#' and builds a \emph{subset expression}.
#'
#' A `FilterStates` object tracks all subsetting expressions
#' (logical predicates that limit observations) associated with a given dataset
#' and composes them into a single reproducible R expression
#' that will assign a subset of the original data to a new variable.
#' This expression is hereafter referred to as \emph{subset expression}.
#'
#' The \emph{subset expression} is constructed differently for different
#' classes of the underlying data object and `FilterStates` subclasses.
#' Currently implemented for `data.frame`, `matrix`,
#' `SummarizedExperiment`, and `MultiAssayExperiment`.
#'
#' @keywords internal
#'
#' @examples
#' library(shiny)
#' filter_states <- teal.slice:::DFFilterStates$new(
#'   dataname = "data",
#'   varlabels = c(x = "x variable", SEX = "Sex"),
#'   datalabel = character(0),
#'   keys = character(0)
#' )
#' filter_state <- teal.slice:::RangeFilterState$new(
#'   c(NA, Inf, seq(1:10)),
#'   varname = "x",
#'   varlabel = "x variable",
#'   dataname = "data",
#'   extract_type = "list"
#' )
#' isolate(filter_state$set_selected(c(3L, 8L)))
#'
#' isolate(
#'   filter_states$state_list_push(
#'     x = filter_state,
#'     state_list_index = 1L,
#'     state_id = "x"
#'   )
#' )
#' isolate(filter_states$get_call())
#'
FilterStates <- R6::R6Class( # nolint
  classname = "FilterStates",

  # public members ----
  public = list(
    #' @description
    #' Initializes `FilterStates` object.
    #'
    #' Initializes `FilterStates` object by setting
    #' `dataname`, and `datalabel`.
    #'
    #' @param dataname (`character(1)`)\cr
    #'   name of the data used in the expression
    #'   specified to the function argument attached to this `FilterStates`
    #' @param datalabel (`character(0)` or `character(1)`)\cr
    #'   text label value
    #'
    #' @return
    #' self invisibly
    #'
    initialize = function(dataname, datalabel) {
      checkmate::assert_string(dataname)
      checkmate::assert_character(datalabel, max.len = 1, any.missing = FALSE)

      private$dataname <- dataname
      private$datalabel <- datalabel

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

    #' @description
    #' Returns the label of the dataset.
    #'
    #' @return `character(1)` the data label
    #'
    get_datalabel = function() {
      private$datalabel
    },

    #' @description
    #' Returns a formatted string representing this `FilterStates` object.
    #'
    #' @param indent (`numeric(1)`) the number of spaces prepended to each line of the output
    #'
    #' @return `character(1)` the formatted string
    #'
    format = function(indent) {
      sprintf(
        paste(
          "%sThis is an instance of an abstract class.",
          "Use child class constructors to instantiate objects."
        ),
        paste(rep(" ", indent), collapse = "")
      )
    },

    #' @description
    #' Filter call
    #'
    #' Builds \emph{subset expression} from condition calls stored in `FilterState`
    #' objects selection. The `lhs` of the expression is `private$dataname`.
    #' The `rhs` is a call to `self$get_fun()` with `private$dataname`
    #' as argument and a list of condition calls from `FilterState` objects
    #' stored in `private$state_list`.
    #' If no filters are applied,
    #' `NULL` is returned to avoid no-op calls such as `x <- x`.
    #'
    #' @return `call` or `NULL`
    #'
    get_call = function() {
      # state_list (list) names must be the same as argument of the function
      # for ... list should be unnamed
      states_list <- private$state_list
      filter_items <- sapply(
        X = states_list,
        USE.NAMES = TRUE,
        simplify = FALSE,
        function(state_list) {
          items <- state_list()
          filtered_items <- Filter(f = function(x) x$is_any_filtered(), x = items)
          calls <- lapply(
            filtered_items,
            function(state) {
              state$get_call()
            }
          )
          calls_combine_by(calls, operator = "&")
        }
      )
      filter_items <- Filter(
        x = filter_items,
        f = Negate(is.null)
      )
      if (length(filter_items) > 0L) {
        filter_function <- str2lang(self$get_fun())
        data_name <- str2lang(private$dataname)
        substitute(
          env = list(
            lhs = data_name,
            rhs = as.call(c(filter_function, c(list(data_name), filter_items)))
          ),
          expr = lhs <- rhs
        )
      } else {
        # return NULL to avoid no-op call
        NULL
      }
    },

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

    #' @description
    #' Gets the name of the function used to filter the data in this `FilterStates`.
    #'
    #' Get name of function used to create the \emph{subset expression}.
    #' Defaults to "subset" but can be overridden by child class method.
    #'
    #' @return `character(1)` the name of the function
    #'
    get_fun = function() {
      "subset"
    },

    # state_list methods ----

    #' @description
    #' Returns a list of `FilterState` objects stored in this `FilterStates`.
    #'
    #' @param state_list_index (`character(1)`, `integer(1)`)\cr
    #'   index on the list in `private$state_list` where filter states are kept
    #' @param state_id (`character(1)`)\cr
    #'   name of element in a filter state (which is a `reactiveVal` containing a list)
    #'
    #' @return `list` of `FilterState` objects
    #'
    state_list_get = function(state_list_index, state_id = NULL) {
      private$validate_state_list_exists(state_list_index)
      checkmate::assert_string(state_id, null.ok = TRUE)

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

    #' @description
    #' Adds a new `FilterState` object to this `FilterStates`.\cr
    #' Raises error if the length of `x` does not match the length of `state_id`.
    #'
    #' @param x (`FilterState`)\cr
    #'   object to be added to filter state list
    #' @param state_list_index (`character(1)`, `integer(1)`)\cr
    #'   index on the list in `private$state_list` where filter states are kept
    #' @param state_id (`character(1)`)\cr
    #'   name of element in a filter state (which is a `reactiveVal` containing a list)
    #'
    #' @return NULL
    #'
    state_list_push = function(x, state_list_index, state_id) {
      logger::log_trace(
        "{ class(self)[1] } pushing into state_list, dataname: { private$dataname }"
      )
      private$validate_state_list_exists(state_list_index)
      checkmate::assert_string(state_id)

      states <- if (is.list(x)) {
        x
      } else {
        list(x)
      }

      state <- stats::setNames(states, state_id)
      new_state_list <- c(private$state_list[[state_list_index]](), state)
      private$state_list[[state_list_index]](new_state_list)

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

    #' @description
    #' Removes a single filter state with all associated shiny elements:\cr
    #' * specified `FilterState` from `private$state_list`
    #' * UI card created for this filter
    #' * observers tracking the selection and remove button
    #'
    #' @param state_list_index (`character(1)`, `integer(1)`)\cr
    #'   index on the list in `private$state_list` where filter states are kept
    #' @param state_id (`character(1)`)\cr
    #'   name of element in a filter state (which is a `reactiveVal` containing a list)
    #'
    #' @return NULL
    #'
    state_list_remove = function(state_list_index, state_id) {
      logger::log_trace(paste(
        "{ class(self)[1] } removing a filter from state_list { state_list_index },",
        "dataname: { private$dataname }"
      ))
      private$validate_state_list_exists(state_list_index)
      checkmate::assert_string(state_id)
      checkmate::assert(
        checkmate::check_string(state_list_index),
        checkmate::check_int(state_list_index)
      )

      new_state_list <- private$state_list[[state_list_index]]()
      new_state_list[[state_id]] <- NULL
      private$state_list[[state_list_index]](new_state_list)

      logger::log_trace(paste(
        "{ class(self)[1] } removed from state_list { state_list_index },",
        "dataname: { private$dataname }"
      ))
      invisible(NULL)
    },

    #' @description
    #' Remove all `FilterState` objects from this `FilterStates` object.
    #'
    #' @return NULL
    #'
    state_list_empty = function() {
      logger::log_trace(
        "{ class(self)[1] } emptying state_list, dataname: { private$dataname }"
      )

      for (i in seq_along(private$state_list)) {
        private$state_list[[i]](list())
      }

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

    #' @description
    #' Gets the number of active `FilterState` objects in this `FilterStates` object.
    #'
    #' @return `integer(1)`
    #'
    get_filter_count = function() {
      sum(vapply(private$state_list, function(state_list) {
        length(state_list())
      }, FUN.VALUE = integer(1)))
    },

    #' @description Remove a single `FilterState` from `state_list`.
    #'
    #' @param state_id (`character`)\cr
    #'   name of variable for which to remove `FilterState`
    #'
    #' @return `NULL`
    #'
    remove_filter_state = function(state_id) {
      stop("This variable can not be removed from the filter.")
    },

    # shiny modules ----

    #' @description
    #' Shiny module UI
    #'
    #' Shiny UI element that stores `FilterState` UI elements.
    #' Populated with elements created with `renderUI` in the module server.
    #'
    #' @param id (`character(1)`)\cr
    #'   shiny element (module instance) id
    #'
    #' @return `shiny.tag`
    #'
    ui = function(id) {
      ns <- NS(id)
      private$cards_container_id <- ns("cards")
      tagList(
        include_css_files(pattern = "filter-panel"),
        tags$div(
          id = private$cards_container_id,
          class = "list-group hideable-list-group",
          `data-label` = ifelse(private$datalabel == "", "", (paste0("> ", private$datalabel)))
        )
      )
    },

    #' @description
    #' Gets reactive values from active `FilterState` objects.
    #'
    #' Get active filter state from `FilterState` objects stored in `state_list`(s).
    #' The output is a list compatible with input to `self$set_filter_state`.
    #'
    #' @return `list` containing `list` per `FilterState` in the `state_list`
    #'
    get_filter_state = function() {
      stop("Pure virtual method.")
    },

    #' @description
    #' Sets active `FilterState` objects.
    #'
    #' @param data (`data.frame`)\cr
    #'   data object for which to define a subset
    #' @param state (`named list`)\cr
    #'   should contain values of initial selections in the `FilterState`;
    #'   `list` names must correspond to column names in `data`
    #' @param filtered_dataset
    #'   data object for which to define a subset(?)
    #'
    set_filter_state = function(data, state, filtered_dataset) {
      stop("Pure virtual method.")
    },

    #' @description
    #' Shiny module UI that adds a filter variable.
    #'
    #' @param id (`character(1)`)\cr
    #'   shiny element (module instance) id
    #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr
    #'   data object for which to define a subset
    #'
    #' @return `shiny.tag`
    #'
    ui_add_filter_state = function(id, data) {
      div("This object cannot be filtered")
    },

    #' @description
    #' Shiny module server that adds a filter variable.
    #'
    #' @param id (`character(1)`)\cr
    #'   shiny module instance id
    #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr
    #'   data object for which to define a subset
    #' @param ... ignored
    #'
    #' @return `moduleServer` function which returns `NULL`
    #'
    srv_add_filter_state = function(id, data, ...) {
      check_ellipsis(..., stop = FALSE)
      moduleServer(
        id = id,
        function(input, output, session) {
          NULL
        }
      )
    }
  ),
  private = list(
    # private fields ----
    cards_container_id = character(0),
    card_ids = character(0),
    datalabel = character(0),
    dataname = NULL, # because it holds object of class name
    ns = NULL, # shiny ns()
    observers = list(), # observers
    state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes

    # private methods ----

    # Module to insert/remove `FilterState` UI
    #
    # This module adds the shiny UI of the `FilterState` object newly added
    # to state_list to the Active Filter Variables,
    # calls `FilterState` modules and creates an observer to remove state
    # parameter filter_state (`FilterState`).
    #
    # @param id (`character(1)`)\cr
    #   shiny module instance id
    # @param filter_state (`named list`)\cr
    #   should contain values of initial selections in the `FilterState`;
    #   `list` names must correspond to column names in `data`
    # @param state_list_index (`character(1)`, `integer(1)`)\cr
    #   index on the list in `private$state_list` where filter states are kept
    # @param state_id (`character(1)`)\cr
    #   name of element in a filter state (which is a `reactiveVal` containing a list)
    #
    # @return `moduleServer` function which returns `NULL`
    #
    insert_filter_state_ui = function(id, filter_state, state_list_index, state_id) {
      checkmate::assert_class(filter_state, "FilterState")
      checkmate::assert(
        checkmate::check_int(state_list_index),
        checkmate::check_character(state_list_index, len = 1),
        combine = "or"
      )
      checkmate::assert_character(state_id, len = 1)
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace(
            sprintf(
              "%s$insert_filter_state_ui, adding FilterState UI of variable %s, dataname: %s",
              class(self)[1],
              state_id,
              private$dataname
            )
          )

          # card_id of inserted card must be saved in private$card_ids as
          # it might be removed by the several events:
          #   - remove button in FilterStates module
          #   - remove button in FilteredDataset module
          #   - remove button in FilteredData module
          #   - API call remove_filter_state
          card_id <- session$ns("card")
          state_list_id <- sprintf("%s-%s", state_list_index, state_id)
          private$card_ids[state_list_id] <- card_id

          insertUI(
            selector = sprintf("#%s", private$cards_container_id),
            where = "beforeEnd",
            # add span with id to be removable
            ui = div(
              id = card_id,
              class = "list-group-item",
              filter_state$ui(session$ns("content"))
            )
          )
          # signal sent from filter_state when it is marked for removal
          remove_fs <- filter_state$server(id = "content")

          private$observers[[state_list_id]] <- observeEvent(
            ignoreInit = TRUE,
            ignoreNULL = TRUE,
            eventExpr = remove_fs(),
            handlerExpr = {
              logger::log_trace(paste(
                "{ class(self)[1] }$insert_filter_state_ui@1",
                "removing FilterState from state_list '{ state_list_index }',",
                "dataname: { private$dataname }"
              ))
              self$state_list_remove(state_list_index, state_id)
              logger::log_trace(paste(
                "{ class(self)[1] }$insert_filter_state_ui@1",
                "removed FilterState from state_list '{ state_list_index }',",
                "dataname: { private$dataname }"
              ))
            }
          )

          logger::log_trace(
            sprintf(
              "%s$insert_filter_state_ui, added FilterState UI of variable %s, dataname: %s",
              class(self)[1],
              state_id,
              private$dataname
            )
          )
          NULL
        }
      )
    },

    # Remove shiny element. Method can be called from reactive session where
    # `observeEvent` for remove-filter-state is set and also from `FilteredDataset`
    # level, where shiny-session-namespace is different. That is why it's important
    # to remove shiny elements from anywhere. In `add_filter_state` `session$ns(NULL)`
    # is equivalent to `private$ns(state_list_index)`.
    # In addition, an unused reactive is being removed from input:
    # method searches input for the unique matches with the filter name
    # and then removes objects constructed with current card id + filter name.
    #
    remove_filter_state_ui = function(state_list_index, state_id, .input) {
      state_list_id <- sprintf("%s-%s", state_list_index, state_id)
      removeUI(selector = sprintf("#%s", private$card_ids[state_list_id]))
      private$card_ids <- private$card_ids[names(private$card_ids) != state_list_id]
      if (length(private$observers[[state_list_id]]) > 0) {
        private$observers[[state_list_id]]$destroy()
        private$observers[[state_list_id]] <- NULL
      }
      # Remove unused reactive from shiny input (leftover of removeUI).
      # This default behavior may change in the future, making this part obsolete.
      prefix <- paste0(gsub("cards$", "", private$cards_container_id))
      invisible(
        lapply(
          unique(grep(state_id, names(.input), value = TRUE)),
          function(i) {
            .subset2(.input, "impl")$.values$remove(paste0(prefix, i))
          }
        )
      )
    },
    # Checks if the state_list of the given index was initialized in this `FilterStates`
    # @param state_list_index (character or integer)
    validate_state_list_exists = function(state_list_index) {
      checkmate::assert(
        checkmate::check_string(state_list_index),
        checkmate::check_int(state_list_index)
      )
      if (
        !(
          is.numeric(state_list_index) &&
            all(state_list_index <= length(private$state_list) && state_list_index > 0) ||
            is.character(state_list_index) && all(state_list_index %in% names(private$state_list))
        )
      ) {
        stop(
          paste(
            "Filter state list",
            state_list_index,
            "has not been initialized in FilterStates object belonging to the dataset",
            private$datalabel
          )
        )
      }
    },

    # Maps the array of strings to sanitized unique HTML ids.
    # @param keys `character` the array of strings
    # @param prefix `character(1)` text to prefix id. Needed in case of multiple
    #  state_list objects where keys (variables) might be duplicated across state_lists
    # @return `list` the mapping
    map_vars_to_html_ids = function(keys, prefix = "") {
      checkmate::assert_character(keys, null.ok = TRUE)
      checkmate::assert_character(prefix, len = 1)
      sanitized_values <- make.unique(gsub("[^[:alnum:]]", perl = TRUE, replacement = "", x = keys))
      sanitized_values <- paste(prefix, "var", sanitized_values, sep = "_")
      stats::setNames(object = sanitized_values, nm = keys)
    }
  )
)

#' @name CDISCFilteredData
#' @docType class
#'
#' @title Class to encapsulate relational filtered datasets with its parents.
#' @description `r lifecycle::badge("stable")`
#' @details
#' The `CDISCFilteredData` class implements logic to filter a relational
#' dataset by inheriting from `FilteredData`.
#' A dataset can have up to one parent dataset. Rows are identified by the foreign
#' key and only those rows that appear in the parent dataset are kept in the filtered
#' dataset.
#'
#' The teal UI works with objects of class `FilteredData` which may mix CDISC and other
#' data (e.g. `iris`).
#'
#' @seealso `FilteredData` class
#'
#' @examples
#' library(scda)
#' library(teal.data)
#'
#' ADSL <- synthetic_cdisc_data("latest")$adsl
#' ADTTE <- synthetic_cdisc_data("latest")$adtte
#' datasets <- teal.slice:::CDISCFilteredData$new(
#'   list(
#'     ADSL = list(dataset = ADSL, keys = c("STUDYID", "USUBJID")),
#'     ADTTE = list(dataset = ADTTE, keys = c("STUDYID", "USUBJID", "PARAMCD"), parent = "ADSL")
#'   ),
#'   check = FALSE,
#'   join_keys = join_keys(join_key("ADSL", "ADTTE", c("STUDYID", "USUBJID")))
#' )
#'
#' # to avoid using isolate(), you can provide a default isolate context by calling
#' # options(shiny.suppressMissingContextError = TRUE) #nolint
#' # don't forget to deactivate this option at the end
#' # options(shiny.suppressMissingContextError = FALSE) #nolint
#'
#' isolate({
#'   datasets$datanames()
#'
#'   # number observations and subjects of filtered/non-filtered dataset
#'   datasets$get_filter_overview("ADSL")
#'
#'   print(datasets$get_call("ADSL"))
#'   print(datasets$get_call("ADTTE"))
#'
#'   df <- datasets$get_data("ADSL", filtered = FALSE)
#'   print(df)
#' })
#'
#'
#' isolate(datasets$set_filter_state(list(ADTTE = list(PARAMCD = "OS"))))
#' isolate(datasets$get_filter_state())
CDISCFilteredData <- R6::R6Class( # nolint
  "CDISCFilteredData",
  inherit = FilteredData,
  ## CDISCFilteredData ====
  ## __Public Methods ====
  public = list(
    #' @description
    #' Get datanames
    #'
    #' The datanames are returned in the order in which they must be
    #' evaluated (in case of dependencies).
    #' @return (`character` vector) of datanames
    datanames = function() {
      datanames <- super$datanames()
      child_parent <- sapply(datanames, function(i) self$get_parentname(i), USE.NAMES = TRUE, simplify = FALSE)
      ordered_datanames <- topological_sort(child_parent)
      return(as.character(intersect(as.character(ordered_datanames), datanames)))
    },

    #' @description
    #'
    #' Produces language required to filter a single dataset and merge it with its parent.
    #' The datasets in question are assumed to be available.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @return (`call` or `list` of calls ) to filter dataset
    #'
    get_call = function(dataname) {
      parent_dataname <- self$get_parentname(dataname)

      if (length(parent_dataname) == 0) {
        super$get_call(dataname)
      } else {
        dataset <- self$get_filtered_dataset(dataname)
        premerge_call <- Filter(
          f = Negate(is.null),
          x = lapply(
            dataset$get_filter_states(),
            function(x) x$get_call()
          )
        )

        join_keys <- self$get_join_keys()
        keys <-
          if (!is.null(join_keys)) {
            join_keys$get(parent_dataname, dataname)
          } else {
            character(0)
          }
        parent_keys <- names(keys)
        dataset_keys <- unname(keys)

        y_arg <-
          if (length(parent_keys) == 0L) {
            parent_dataname
          } else {
            sprintf("%s[, c(%s), drop = FALSE]", parent_dataname, toString(dQuote(parent_keys, q = FALSE)))
          }
        more_args <-
          if (length(parent_keys) == 0 || length(dataset_keys) == 0) {
            list()
          } else if (identical(parent_keys, dataset_keys)) {
            list(by = parent_keys)
          } else {
            list(by = stats::setNames(parent_keys, dataset_keys))
          }

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

        c(premerge_call, merge_call)
      }
    },

    #' @description
    #' Get names of datasets available for filtering
    #'
    #' @param dataname (`character` vector) names of the dataset
    #' @return (`character` vector) of dataset names
    get_filterable_datanames = function(dataname) {
      parents <- character(0)
      for (i in dataname) {
        while (length(i) > 0) {
          parent_i <- self$get_parentname(i)
          parents <- c(parents, parent_i)
          i <- parent_i
        }
      }

      return(unique(c(parents, dataname)))
    },

    #' @description
    #' Gets variable names of a given dataname for the filtering. This excludes parent dataset variable names.
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @return (`character` vector) of variable names
    get_filterable_varnames = function(dataname) {
      varnames <- self$get_filtered_dataset(dataname)$get_filterable_varnames()
      parent_dataname <- self$get_parentname(dataname)
      parent_varnames <- if (length(parent_dataname) > 0) {
        # cannot call get_filterable_varnames on the parent filtered_dataset in case
        # some of its variables are set to be non-filterable
        get_supported_filter_varnames(self$get_filtered_dataset(parent_dataname))
      }
      setdiff(varnames, parent_varnames)
    },

    #' @description
    #' Get filter overview table in form of X (filtered) / Y (non-filtered)
    #'
    #' This is intended to be presented in the application.
    #'
    #' @param datanames (`character` vector) names of the dataset (or "all")
    #'
    #' @return (`matrix`) matrix of observations and subjects of all datasets
    get_filter_overview = function(datanames) {
      if (identical(datanames, "all")) {
        datanames <- self$datanames()
      }
      check_in_subset(datanames, self$datanames(), "Some datasets are not available: ")

      rows <- lapply(
        datanames,
        function(dataname) {
          obs <- self$get_filtered_dataset(dataname)$get_filter_overview_info(
            filtered_dataset = self$get_data(dataname = dataname, filtered = TRUE)
          )[, 1]

          subs <- private$get_filter_overview_nsubjs(dataname)

          df <- cbind(
            obs, subs
          )

          rownames(df) <- if (!is.null(names(obs))) {
            names(obs)
          } else {
            dataname
          }
          colnames(df) <- c("Obs", "Subjects")
          df
        }
      )

      do.call(rbind, rows)
    },

    #' @description
    #' Get parent dataset name
    #'
    #' @param dataname (`character(1)`) name of the dataset
    #' @return (`character`) name of parent dataset
    get_parentname = function(dataname) {
      private$parents[[dataname]]
    },

    #' @description
    #' Add dataset
    #'
    #' Add dataset and preserve all attributes attached to this object.
    #' Technically `set_dataset` created `FilteredDataset` which keeps
    #' `dataset` for filtering purpose.
    #'
    #' @param dataset_args (`list`)\cr
    #'   containing the arguments except (`dataname`)
    #'   needed by `init_filtered_dataset` (can also
    #'   include `parent` which will be ignored)
    #' @param dataname (`character(1)`)\cr
    #'   the name of the `dataset` to be added to this object
    #' @return (`self`) object of this class
    set_dataset = function(dataset_args, dataname) {
      logger::log_trace("CDISCFilteredData$set_dataset setting dataset, name: { dataname }")
      validate_dataset_args(dataset_args, dataname, allowed_parent = TRUE)

      parent_dataname <- dataset_args[["parent"]]
      dataset_args[["parent"]] <- NULL
      private$parents[[dataname]] <- parent_dataname

      if (length(parent_dataname) == 0) {
        super$set_dataset(dataset_args, dataname)
      } else {
        dataset <- dataset_args[["dataset"]]
        dataset_args[["dataset"]] <- NULL

        # to include it nicely in the Show R Code; the UI also uses datanames in ids, so no whitespaces allowed
        check_simple_name(dataname)
        private$filtered_datasets[[dataname]] <- do.call(
          what = init_filtered_dataset,
          args = c(list(dataset), dataset_args, list(dataname = dataname))
        )

        private$reactive_data[[dataname]] <- reactive({
          env <- new.env(parent = parent.env(globalenv()))
          env[[dataname]] <- self$get_filtered_dataset(dataname)$get_dataset()
          env[[private$parents[[dataname]]]] <-
            private$reactive_data[[private$parents[[dataname]]]]()

          filter_call <- self$get_call(dataname)
          eval_expr_with_msg(filter_call, env)
          get(x = dataname, envir = env)
        })
      }

      invisible(self)
    }
  ),

  ## __Private Methods---------------------
  private = list(

    # named list of dataset parents parents[[child_dataset]] = its parent
    parents = NULL,

    # datanames in the order in which they must be evaluated (in case of dependencies)
    # this is a reactive and kept as a field for caching
    ordered_datanames = NULL,
    validate = function() {
      stopifnot(
        setequal(private$ordered_datanames, names(private$dataset_filters)),
      )
      super$validate()
    },
    get_filter_overview_nsubjs = function(dataname) {
      # Gets filter overview subjects number and returns a list
      # of the number of subjects of filtered/non-filtered datasets
      subject_keys <- if (length(self$get_parentname(dataname)) > 0) {
        self$get_keys(self$get_parentname(dataname))
      } else {
        self$get_filtered_dataset(dataname)$get_keys()
      }

      self$get_filtered_dataset(dataname)$get_filter_overview_nsubjs(
        self$get_data(dataname = dataname, filtered = TRUE),
        subject_keys
      )
    }
  )
)

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

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

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

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

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

#' @name FilterState
#' @docType class
#'
#'
#' @title FilterState Abstract Class
#'
#' @description Abstract class to encapsulate filter states
#'
#' @details
#' This class is responsible for managing single filter item within
#' `FilteredData` class. Filter states depend on the variable type:
#' (`logical`, `integer`, `numeric`, `factor`, `character`, `Date`, `POSIXct`, `POSIXlt`)
#' and returns `FilterState` object with class corresponding to input variable.
#' Class controls single filter entry in `module_single_filter_item` and returns
#' code relevant to selected values.
#' - `factor`, `character`: `class = ChoicesFilterState`
#' - `numeric`: `class = RangeFilterState`
#' - `logical`: `class = LogicalFilterState`
#' - `Date`: `class = DateFilterState`
#' - `POSIXct`, `POSIXlt`: `class = DatetimeFilterState`
#' - all `NA` entries: `class: FilterState`, cannot be filtered
#' - default: `FilterState`, cannot be filtered
#' \cr
#' Each variable's filter state is an `R6` object which contains `choices`,
#' `selected`, `varname`, `dataname`, `labels`, `na_count`, `keep_na` and other
#' variable type specific fields (`keep_inf`, `inf_count`, `timezone`).
#' Object contains also shiny module (`ui` and `server`) which manages
#' state of the filter through reactive values `selected`, `keep_na`, `keep_inf`
#' which trigger `get_call()` and every R function call up in reactive
#' chain.
#' \cr
#' \cr
#' @section Modifying state:
#' Modifying a `FilterState` object is possible in three scenarios:
#' * In the interactive session by directly specifying values of `selected`,
#'   `keep_na` or `keep_inf` using `set_state` method (to update all at once),
#'   or using `set_selected`, `set_keep_na` or `set_keep_inf`
#' * 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`)\cr
    #'   values of the variable used in filter
    #' @param varname (`character`)\cr
    #'   name of the variable
    #' @param varlabel (`character(1)`)\cr
    #'   label of the variable (optional).
    #' @param dataname (`character(1)`)\cr
    #'   name of dataset where `x` is taken from. Must be specified if `extract_type` argument
    #'   is not empty.
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by dataname. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #'
    #' @return self invisibly
    #'
    initialize = function(x,
                          varname,
                          varlabel = character(0),
                          dataname = NULL,
                          extract_type = character(0)) {
      checkmate::assert_string(varname)
      checkmate::assert_character(varlabel, max.len = 1, any.missing = FALSE)
      checkmate::assert_string(dataname, null.ok = TRUE)
      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"))
      }
      if (length(extract_type) == 1 && is.null(dataname)) {
        stop("if extract_type is specified, dataname must also be specified")
      }

      private$dataname <- dataname
      private$varname <- varname
      private$varlabel <- if (identical(varlabel, as.character(varname))) {
        # to not display duplicated label
        character(0)
      } else {
        varlabel
      }
      private$extract_type <- extract_type
      private$selected <- reactiveVal(NULL)
      private$na_count <- sum(is.na(x))
      private$keep_na <- reactiveVal(FALSE)
      logger::log_trace(
        sprintf(
          "Instantiated %s with variable %s, dataname: %s",
          class(self)[1],
          private$varname,
          private$dataname
        )
      )
      invisible(self)
    },

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

    #' @description
    #' Returns a formatted string representing this `FilterState`.
    #'
    #' @param indent (`numeric(1)`)
    #'   number of spaces before after each new line character of the formatted string;
    #'   defaults to 0
    #' @param wrap_width (`numeric(1)`)
    #'   number of characters to wrap lines at in the printed output;
    #'   allowed range is 30 to 120; defaults to 76
    #'
    #' @return `character(1)` the formatted string
    #'
    format = function(indent = 0L, wrap_width = 76L) {
      checkmate::assert_number(indent, finite = TRUE, lower = 0L)
      checkmate::assert_number(wrap_width, finite = TRUE, lower = 30L, upper = 120L)

      # List all selected values separated by commas.
      values <- paste(format(self$get_selected(), nsmall = 3L, justify = "none"), collapse = ", ")
      paste(c(
        strwrap(
          sprintf("Filtering on: %s", private$varname),
          width = wrap_width,
          indent = indent
        ),
        # Add wrapping and progressive indent to values enumeration as it is likely to be long.
        strwrap(
          sprintf("Selected values: %s", values),
          width = wrap_width,
          indent = indent + 2L,
          exdent = indent + 4L
        ),
        strwrap(
          sprintf("Include missing values: %s", self$get_keep_na()),
          width = wrap_width,
          indent = indent + 2L
        )
      ), collapse = "\n")
    },

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

    #' @description
    #' Returns dataname or "NULL" if dataname is NULL.
    #'
    #' @return `character(1)`
    #'
    get_dataname = function() {
      if (!is.null(private$dataname)) {
        private$dataname
      } else {
        character(1)
      }
    },

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

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

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

    #' @description
    #' Get selected values from `FilterState`.
    #'
    #' @return class of the returned object depends of class of the `FilterState`
    #'
    get_selected = function() {
      private$selected()
    },

    #' @description
    #' Returns the filtering state.
    #'
    #' @return `list` containing values taken from the reactive fields:
    #' * `selected` (`atomic`) length depends on a `FilterState` variant.
    #' * `keep_na` (`logical(1)`) whether `NA` should be kept.
    #'
    get_state = function() {
      list(
        selected = self$get_selected(),
        keep_na = self$get_keep_na()
      )
    },

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

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

    #' @description
    #' Some methods need an additional `!is.na(varame)` condition to drop
    #' missing values. When `private$na_rm = TRUE`, `self$get_call` returns
    #' condition extended by `!is.na`.
    #'
    #' @param value `logical(1)`\cr
    #'   when `TRUE`, `FilterState$get_call` appends an expression
    #'   removing `NA` values to the filter expression returned by `get_call`
    #'
    #' @return NULL invisibly
    #'
    set_na_rm = function(value) {
      checkmate::assert_flag(value)
      private$na_rm <- value
      invisible(NULL)
    },

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

    #' @description
    #' Set state.
    #'
    #' @param state (`list`)\cr
    #'  contains fields relevant for a specific class:
    #' \itemize{
    #' \item{`selected`}{ defines initial selection}
    #' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
    #' }
    #'
    #' @return NULL invisibly
    #'
    set_state = function(state) {
      logger::log_trace(sprintf(
        "%s$set_state, dataname: %s setting state of variable %s to: selected=%s, keep_na=%s",
        class(self)[1],
        private$dataname,
        private$varname,
        paste(state$selected, collapse = " "),
        state$keep_na
      ))
      stopifnot(is.list(state) && all(names(state) %in% c("selected", "keep_na")))
      if (!is.null(state$keep_na)) {
        self$set_keep_na(state$keep_na)
      }
      if (!is.null(state$selected)) {
        self$set_selected(state$selected)
      }
      logger::log_trace(
        sprintf(
          "%s$set_state, dataname: %s done setting state for variable %s",
          class(self)[1],
          private$dataname,
          private$varname
        )
      )
      invisible(NULL)
    },

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

    #' @description
    #' Shiny module UI.
    #'
    #' @param id (`character(1)`)\cr
    #'  shiny element (module instance) id;
    #'  the UI for this class contains simple message stating that it is not supported
    #'
    ui = function(id) {
      ns <- NS(id)
      fluidPage(
        theme = get_teal_bs_theme(),
        fluidRow(
          column(
            width = 10,
            class = "no-left-right-padding",
            tags$div(
              tags$span(private$varname,
                class = "filter_panel_varname"
              ),
              if (checkmate::test_character(self$get_varlabel(), min.len = 1) &&
                tolower(private$varname) != tolower(self$get_varlabel())) {
                tags$span(self$get_varlabel(), class = "filter_panel_varlabel")
              }
            )
          ),
          column(
            width = 2,
            class = "no-left-right-padding",
            actionLink(
              ns("remove"),
              label = "",
              icon = icon("circle-xmark", lib = "font-awesome"),
              class = "remove pull-right"
            )
          )
        ),
        private$ui_inputs(ns("inputs"))
      )
    }
  ),

  # private members ----
  private = list(
    choices = NULL, # because each class has different choices type
    dataname = character(0),
    keep_na = NULL, # reactiveVal logical()
    na_count = integer(0),
    na_rm = FALSE, # it's logical(1)
    observers = NULL, # here observers are stored
    selected = NULL, # because it holds reactiveVal and each class has different choices type
    varname = character(0),
    varlabel = character(0),
    extract_type = logical(0),

    # private methods ----

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

    # @description
    # Adds `is.na(varname)` before existing condition calls if `keep_na` is selected.
    # Otherwise, if missings are found in the variable `!is.na` will be added
    # only if `private$na_rm = TRUE`
    # @return a `call`
    add_keep_na_call = function(filter_call) {
      if (isTRUE(self$get_keep_na())) {
        call("|", call("is.na", private$get_varname_prefixed()), filter_call)
      } else if (isTRUE(private$na_rm) && private$na_count > 0L) {
        call(
          "&",
          call("!", call("is.na", private$get_varname_prefixed())),
          filter_call
        )
      } else {
        filter_call
      }
    },

    # Sets `keep_na` field according to observed `input$keep_na`
    # If `keep_na = TRUE` `is.na(varname)` is added to the returned call.
    # Otherwise returned call excludes `NA` when executed.
    observe_keep_na = function(input) {

    },

    # @description
    # Set choices is supposed to be executed once in the constructor
    # to define set/range which selection is made from.
    # parameter choices (`vector`)\cr
    #  class of the vector depends on the `FilterState` class.
    # @return `NULL`
    set_choices = function(choices) {
      private$choices <- choices
      invisible(NULL)
    },

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

    # Filters out erroneous values from an array.
    #
    # @param values the array of values
    #
    # @return the array of values without elements, which are outside of
    # the accepted set for this FilterState
    remove_out_of_bound_values = function(values) {
      values
    },

    # Casts an array of values to the type fitting this `FilterState`
    # and validates the elements of the casted array
    # satisfy the requirements of this `FilterState`.
    #
    # @param values the array of values
    #
    # @return the casted array
    #
    # @note throws an error if the casting did not execute successfully.
    cast_and_validate = function(values) {
      values
    },

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

    # @description
    # module displaying input to keep or remove NA in the FilterState call
    # @param id `shiny` id parameter
    #  renders checkbox input only when variable from which FilterState has
    #  been created has some NA values.
    keep_na_ui = function(id) {
      ns <- NS(id)
      if (private$na_count > 0) {
        checkboxInput(
          ns("value"),
          sprintf("Keep NA (%s)", private$na_count),
          value = self$get_keep_na()
        )
      } else {
        NULL
      }
    },

    # @description
    # module to handle NA values in the FilterState
    # @param shiny `id` parameter passed to moduleServer
    #  module sets `private$keep_na` according to the selection.
    #  Module also updates a UI element if the `private$keep_na` has been
    #  changed through the api
    keep_na_srv = function(id) {
      moduleServer(id, function(input, output, session) {
        # this observer is needed in the situation when private$keep_inf has been
        # changed directly by the api - then it's needed to rerender UI element
        # to show relevant values
        private$observers$keep_na_api <- observeEvent(
          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 = self$get_keep_na(),
          handlerExpr = {
            if (!setequal(self$get_keep_na(), input$value)) {
              updateCheckboxInput(
                inputId = "value",
                value = self$get_keep_na()
              )
            }
          }
        )
        private$observers$keep_na <- observeEvent(
          ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput`
          ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
          eventExpr = input$value,
          handlerExpr = {
            keep_na <- if (is.null(input$value)) {
              FALSE
            } else {
              input$value
            }
            self$set_keep_na(keep_na)
            logger::log_trace(
              sprintf(
                "%s$server keep_na of variable %s set to: %s, dataname: %s",
                class(self)[1],
                private$varname,
                deparse1(input$value),
                private$dataname
              )
            )
          }
        )
        invisible(NULL)
      })
    }
  )
)

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

#' Initialize `FilterStates` object
#'
#' Initialize `FilterStates` object
#' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr
#'   the R object which `subset` function is applied on.
#'
#' @param dataname (`character(1)`)\cr
#'   name of the data used in the expression
#'   specified to the function argument attached to this `FilterStates`.
#'
#' @param datalabel (`character(0)` or `character(1)`)\cr
#'   text label value.
#'
#' @param ... (optional)
#'   additional arguments for specific classes: keys
#' @keywords internal
#' @export
#' @examples
#' df <- data.frame(
#'   character = letters,
#'   numeric = seq_along(letters),
#'   date = seq(Sys.Date(), length.out = length(letters), by = "1 day"),
#'   datetime = seq(Sys.time(), length.out = length(letters), by = "33.33 hours")
#' )
#' rf <- teal.slice:::init_filter_states(
#'   data = df,
#'   dataname = "DF",
#'   varlabels = c(
#'     "character variable", "numeric variable", "date variable", "datetime variable"
#'   )
#' )
#' \dontrun{
#' shinyApp(
#'   ui = fluidPage(
#'     actionButton("clear", span(icon("xmark"), "Remove all filters")),
#'     rf$ui_add_filter_state(id = "add", data = df),
#'     rf$ui("states"),
#'     verbatimTextOutput("expr"),
#'   ),
#'   server = function(input, output, session) {
#'     rf$srv_add_filter_state(id = "add", data = df)
#'     rf$server(id = "states")
#'     output$expr <- renderText({
#'       deparse1(rf$get_call(), collapse = "\n")
#'     })
#'     observeEvent(input$clear, rf$state_list_empty())
#'   }
#' )
#' }
init_filter_states <- function(data,
                               dataname,
                               datalabel = character(0),
                               ...) {
  UseMethod("init_filter_states")
}

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

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

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

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

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

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

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

#' @keywords internal
#' @export
get_supported_filter_varnames.FilteredDataset <- function(data) { # nolint
  get_supported_filter_varnames(data$get_dataset())
}

#' @keywords internal
#' @export
get_supported_filter_varnames.MAEFilteredDataset <- function(data) { # nolint
  character(0)
}


#' @title Returns a `choices_labeled` object
#'
#' @param data (`data.frame`, `DFrame`, `list`)\cr
#'   where labels can be taken from in case when `varlabels` is not specified.
#'   `data` must be specified if `varlabels` is not specified.
#' @param choices (`character`)\cr
#'  the array of chosen variables
#' @param varlabels (`character`)\cr
#'  the labels of variables in data
#' @param keys (`character`)\cr
#'  the names of the key columns in data
#' @return `character(0)` if choices are empty; a `choices_labeled` object otherwise
#' @keywords internal
data_choices_labeled <- function(data, choices, varlabels = character(0), keys = character(0)) {
  if (length(choices) == 0) {
    return(character(0))
  }

  choice_labels <- if (identical(varlabels, character(0))) {
    vapply(
      X = data,
      FUN.VALUE = character(1),
      FUN = function(x) {
        label <- attr(x, "label")
        if (length(label) != 1) {
          ""
        } else {
          label
        }
      }
    )[choices]
  } else {
    varlabels
  }

  if (!identical(choice_labels, character(0))) {
    choice_labels[is.na(choice_labels) | choice_labels == ""] <- names(
      choice_labels[is.na(choice_labels) | choice_labels == ""]
    )
    choice_types <- setNames(variable_types(data = data, columns = choices), choices)
    choice_types[keys] <- "primary_key"

    choices_labeled(
      choices = choices,
      labels = unname(choice_labels[choices]),
      types = choice_types[choices]
    )
  } else {
    choices
  }
}

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

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

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

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

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

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

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

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

  return(choices)
}

# DefaultFilteredDataset ------
#' @title The `DefaultFilteredDataset` R6 class
#' @keywords internal
#' @examples
#' library(shiny)
#' ds <- teal.slice:::DefaultFilteredDataset$new(iris, "iris")
#' isolate(
#'   ds$set_filter_state(
#'     state = list(
#'       Species = list(selected = "virginica"),
#'       Petal.Length = list(selected = c(2.0, 5))
#'     )
#'   )
#' )
#' isolate(ds$get_filter_state())
#' isolate(ds$get_call())
DefaultFilteredDataset <- R6::R6Class( # nolint
  classname = "DefaultFilteredDataset",
  inherit = FilteredDataset,
  public = list(

    #' @description
    #' Initializes this `DefaultFilteredDataset` object
    #'
    #' @param dataset (`data.frame`)\cr
    #'  single data.frame for which filters are rendered
    #' @param dataname (`character`)\cr
    #'  A given name for the dataset it may not contain spaces
    #' @param keys optional, (`character`)\cr
    #'   Vector with primary keys
    #' @param label (`character`)\cr
    #'   Label to describe the dataset
    #' @param metadata (named `list` or `NULL`) \cr
    #'   Field containing metadata about the dataset. Each element of the list
    #'   should be atomic and length one.
    initialize = function(dataset, dataname, keys = character(0), label = character(0), metadata = NULL) {
      checkmate::assert_class(dataset, "data.frame")
      super$initialize(dataset, dataname, keys, label, metadata)
      dataname <- self$get_dataname()

      private$add_filter_states(
        filter_states = init_filter_states(
          data = self$get_dataset(),
          dataname = dataname,
          varlabels = self$get_varlabels(),
          keys = self$get_keys()
        ),
        id = "filter"
      )
      invisible(self)
    },

    #' @description
    #' Gets the filter expression
    #'
    #' This functions returns filter calls equivalent to selected items
    #' within each of `filter_states`. Configuration of the calls is constant and
    #' depends on `filter_states` type and order which are set during initialization.
    #' This class contains single `FilterStates`
    #' which contains single `state_list` and all `FilterState` objects
    #' applies to one argument (`...`) in `dplyr::filter` call.
    #' @return filter `call` or `list` of filter calls
    get_call = function() {
      filter_call <- Filter(
        f = Negate(is.null),
        x = lapply(
          self$get_filter_states(),
          function(x) x$get_call()
        )
      )
      if (length(filter_call) == 0) {
        return(NULL)
      }
      filter_call
    },

    #' @description
    #' Gets the reactive values from the active `FilterState` objects.
    #'
    #' Get all active filters from this dataset in form of the nested list.
    #' The output list is a compatible input to `self$set_filter_state`.
    #' @return `list` with named elements corresponding to `FilterState` objects
    #' (active filters).
    get_filter_state = function() {
      self$get_filter_states("filter")$get_filter_state()
    },

    #' @description
    #' Set filter state
    #'
    #' @param state (`named list`)\cr
    #'  containing values of the initial filter. Values should be relevant
    #'  to the referred column.
    #' @param ... Additional arguments. Note that this is currently not used
    #' @examples
    #' dataset <- teal.slice:::DefaultFilteredDataset$new(iris, "iris")
    #' fs <- list(
    #'   Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE),
    #'   Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE)
    #' )
    #' shiny::isolate(dataset$set_filter_state(state = fs))
    #' shiny::isolate(dataset$get_filter_state())
    #'
    #' @return `NULL`
    set_filter_state = function(state, ...) {
      checkmate::assert_list(state)
      logger::log_trace(
        sprintf(
          "DefaultFilteredDataset$set_filter_state setting up filters of variables %s, dataname: %s",
          paste(names(state), collapse = ", "),
          self$get_dataname()
        )
      )

      data <- self$get_dataset()
      fs <- self$get_filter_states()[[1]]
      fs$set_filter_state(state = state, data = data, ...)
      logger::log_trace(
        sprintf(
          "DefaultFilteredDataset$set_filter_state done setting up filters of variables %s, dataname: %s",
          paste(names(state), collapse = ", "),
          self$get_dataname()
        )
      )
      NULL
    },

    #' @description Remove one or more `FilterState` of a `FilteredDataset`
    #'
    #' @param state_id (`character`)\cr
    #'  Vector of character names of variables to remove their `FilterState`.
    #'
    #' @return `NULL`
    remove_filter_state = function(state_id) {
      logger::log_trace(
        sprintf(
          "DefaultFilteredDataset$remove_filter_state removing filters of variable %s, dataname: %s",
          state_id,
          self$get_dataname()
        )
      )

      fdata_filter_state <- self$get_filter_states()[[1]]
      for (element in state_id) {
        fdata_filter_state$remove_filter_state(element)
      }
      logger::log_trace(
        sprintf(
          "DefaultFilteredDataset$remove_filter_state done removing filters of variable %s, dataname: %s",
          state_id,
          self$get_dataname()
        )
      )
      invisible(NULL)
    },

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

    #' @description
    #' Server module to add filter variable for this dataset
    #'
    #' Server module to add filter variable for this dataset.
    #' For this class `srv_add_filter_state` calls single module
    #' `srv_add_filter_state` from `FilterStates` (`DefaultFilteredDataset`
    #' contains single `FilterStates`)
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param ... other arguments passed on to child `FilterStates` methods.
    #'
    #' @return `moduleServer` function which returns `NULL`
    srv_add_filter_state = function(id, ...) {
      check_ellipsis(..., stop = FALSE, allowed_args = "vars_include")
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace(
            "DefaultFilteredDataset$srv_add_filter_state initializing, dataname: { deparse1(self$get_dataname()) }"
          )
          data <- self$get_dataset()
          self$get_filter_states(id = "filter")$srv_add_filter_state(
            id = "filter",
            data = data,
            ...
          )
          logger::log_trace(
            "DefaultFilteredDataset$srv_add_filter_state initialized, dataname: { deparse1(self$get_dataname()) }"
          )
          NULL
        }
      )
    },

    #' @description
    #' Get number of observations based on given keys
    #' The output shows the comparison between `filtered_dataset`
    #' function parameter and the dataset inside self
    #' @param filtered_dataset comparison object, of the same class
    #' as `self$get_dataset()`, if `NULL` then `self$get_dataset()`
    #' is used.
    #' @param subject_keys (`character` or `NULL`) columns denoting unique subjects when
    #' calculating the filtering.
    #' @return `list` containing character `#filtered/#not_filtered`
    get_filter_overview_nsubjs = function(filtered_dataset = self$get_dataset(), subject_keys = NULL) {
      checkmate::assert_class(filtered_dataset, classes = class(self$get_dataset()))
      checkmate::assert_character(subject_keys, null.ok = TRUE, any.missing = FALSE)

      f_rows <- if (length(subject_keys) == 0) {
        dplyr::n_distinct(filtered_dataset)
      } else {
        dplyr::n_distinct(filtered_dataset[subject_keys])
      }

      nf_rows <- if (length(subject_keys) == 0) {
        dplyr::n_distinct(self$get_dataset())
      } else {
        dplyr::n_distinct(self$get_dataset()[subject_keys])
      }

      list(paste0(f_rows, "/", nf_rows))
    }
  ),
  private = list(
    # Gets filter overview observations number and returns a
    # list of the number of observations of filtered/non-filtered datasets
    get_filter_overview_nobs = function(filtered_dataset) {
      f_rows <- nrow(filtered_dataset)
      nf_rows <- nrow(self$get_dataset())
      list(
        paste0(f_rows, "/", nf_rows)
      )
    }
  )
)

#' Initializes `FilteredDataset`
#'
#' @keywords internal
#' @examples
#' # DefaultFilteredDataset example
#' iris_fd <- teal.slice:::init_filtered_dataset(
#'   iris,
#'   dataname = "iris",
#'   metadata = list(type = "teal")
#' )
#' \dontrun{
#' shinyApp(
#'   ui = fluidPage(
#'     iris_fd$ui_add_filter_state(id = "add"),
#'     iris_fd$ui("dataset"),
#'     verbatimTextOutput("call"),
#'     verbatimTextOutput("metadata")
#'   ),
#'   server = function(input, output, session) {
#'     iris_fd$srv_add_filter_state(id = "add")
#'     iris_fd$server(id = "dataset")
#'
#'     output$metadata <- renderText({
#'       paste("Type =", iris_fd$get_metadata()$type)
#'     })
#'
#'     output$call <- renderText({
#'       paste(
#'         vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),
#'         collapse = "\n"
#'       )
#'     })
#'   }
#' )
#' }
#'
#' # MAEFilteredDataset example
#' library(MultiAssayExperiment)
#' data(miniACC)
#' MAE_fd <- teal.slice:::init_filtered_dataset(miniACC, "MAE", metadata = list(type = "MAE"))
#' \dontrun{
#' shinyApp(
#'   ui = fluidPage(
#'     MAE_fd$ui_add_filter_state(id = "add"),
#'     MAE_fd$ui("dataset"),
#'     verbatimTextOutput("call"),
#'     verbatimTextOutput("metadata")
#'   ),
#'   server = function(input, output, session) {
#'     MAE_fd$srv_add_filter_state(id = "add")
#'     MAE_fd$server(id = "dataset")
#'     output$metadata <- renderText({
#'       paste("Type =", MAE_fd$get_metadata()$type)
#'     })
#'     output$call <- renderText({
#'       paste(
#'         vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),
#'         collapse = "\n"
#'       )
#'     })
#'   }
#' )
#' }
#' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr
#' @param dataname (`character`)\cr
#'  A given name for the dataset it may not contain spaces
#' @param keys optional, (`character`)\cr
#'   Vector with primary keys
#' @param label (`character`)\cr
#'   Label to describe the dataset
#' @param metadata (named `list` or `NULL`) \cr
#'   Field containing metadata about the dataset. Each element of the list
#'   should be atomic and length one.
#' @export
#' @note Although this function is exported for use in other packages, it may be changed or removed in a future release
#'   at which point any code which relies on this exported function will need to be changed.
init_filtered_dataset <- function(dataset, # nolint
                                  dataname,
                                  keys = character(0),
                                  label = attr(dataset, "label"),
                                  metadata = NULL) {
  UseMethod("init_filtered_dataset")
}

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

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

# FilteredDataset abstract --------
#' @title `FilterStates` R6 class
#' @description
#' `FilteredDataset` is a class which renders/controls `FilterStates`(s)
#' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one
#' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects.
#' Each `FilterStates` is responsible for one filter/subset expression applied for specific
#' components of the dataset.
#' @keywords internal
FilteredDataset <- R6::R6Class( # nolint
  "FilteredDataset",
  ## __Public Methods ====
  public = list(
    #' @description
    #' Initializes this `FilteredDataset` object
    #'
    #' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr
    #'  single dataset for which filters are rendered
    #' @param dataname (`character(1)`)\cr
    #'  A given name for the dataset it may not contain spaces
    #' @param keys optional, (`character`)\cr
    #'   Vector with primary keys
    #' @param label (`character(1)`)\cr
    #'   Label to describe the dataset
    #' @param metadata (named `list` or `NULL`) \cr
    #'   Field containing metadata about the dataset. Each element of the list
    #'   should be atomic and length one.
    initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label"), metadata = NULL) {
      # dataset assertion in child classes

      check_simple_name(dataname)
      checkmate::assert_character(keys, any.missing = FALSE)
      checkmate::assert_character(label, null.ok = TRUE)
      teal.data::validate_metadata(metadata)

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


    #' @description
    #' Returns a string representation of the filter state in this `FilteredDataset`.
    #'
    #' @return `character(1)` the formatted string representing the filter state or
    #' `NULL` if no filter state is present.
    #'
    get_formatted_filter_state = function() {
      out <- Filter(
        function(x) x != "",
        sapply(
          self$get_filter_states(),
          function(states) {
            states$format(indent = 2)
          }
        )
      )
      if (length(out) > 0) {
        header <- paste0("Filters for dataset: ", self$get_dataname())
        paste(c(header, out), collapse = "\n")
      }
    },

    #' @description
    #' Removes all active filter items applied to this dataset
    #' @return NULL
    state_lists_empty = function() {
      logger::log_trace("Removing all filters from FilteredDataset: { deparse1(self$get_dataname()) }")
      lapply(
        self$get_filter_states(),
        function(state_list) state_list$state_list_empty()
      )
      logger::log_trace("Removed all filters from FilteredDataset: { deparse1(self$get_dataname()) }")
      NULL
    },
    # managing filter states -----


    # getters ----
    #' @description
    #' Gets a filter expression
    #'
    #' This functions returns filter calls equivalent to selected items
    #' within each of `filter_states`. Configuration of the calls is constant and
    #' depends on `filter_states` type and order which are set during initialization.
    #' @return filter `call` or `list` of filter calls
    get_call = function() {
      stop("Pure virtual method.")
    },

    #' Gets the reactive values from the active `FilterState` objects.
    #'
    #' Get all active filters from this dataset in form of the nested list.
    #' The output list is a compatible input to `self$set_filter_state`.
    #' @return `list` with named elements corresponding to `FilterStates` objects
    #' with active filters.
    get_filter_state = function() {
      states <- lapply(self$get_filter_states(), function(x) x$get_filter_state())
      Filter(function(x) length(x) > 0, states)
    },

    #' @description
    #' Gets the active `FilterStates` objects.
    #' @param id (`character(1)`, `character(0)`)\cr
    #'   the id of the `private$filter_states` list element where `FilterStates` is kept.
    #' @return `FilterStates` or `list` of `FilterStates` objects.
    get_filter_states = function(id = character(0)) {
      if (length(id) == 0) {
        private$filter_states
      } else {
        private$filter_states[[id]]
      }
    },

    #' @description
    #' Gets the number of active `FilterState` objects in all `FilterStates` in this `FilteredDataset`.
    #' @return `integer(1)`
    get_filter_count = function() {
      sum(vapply(private$filter_states,
        function(state) state$get_filter_count(),
        FUN.VALUE = integer(1)
      ))
    },

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

    #' @description
    #' Gets the dataset object in this `FilteredDataset`
    #' @return `data.frame` or `MultiAssayExperiment`
    get_dataset = function() {
      private$dataset
    },

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

    #' @description
    #' Get filter overview rows of a dataset
    #' The output shows the comparison between `filtered_dataset`
    #' function parameter and the dataset inside self
    #' @param filtered_dataset comparison object, of the same class
    #' as `self$get_dataset()`, if `NULL` then `self$get_dataset()`
    #' is used.
    #' @return (`matrix`) matrix of observations and subjects
    get_filter_overview_info = function(filtered_dataset = self$get_dataset()) {
      checkmate::assert_class(filtered_dataset, classes = class(self$get_dataset()))
      df <- cbind(private$get_filter_overview_nobs(filtered_dataset), "")
      rownames(df) <- self$get_dataname()
      colnames(df) <- c("Obs", "Subjects")
      df
    },

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

    #' @description
    #' Gets labels of variables in the data
    #'
    #' Variables are the column names of the data.
    #' Either, all labels must have been provided for all variables
    #' in `set_data` or `NULL`.
    #'
    #' @param variables (`character` vector) variables to get labels for;
    #'   if `NULL`, for all variables in data
    #' @return (`character` or `NULL`) variable labels, `NULL` if `column_labels`
    #'   attribute does not exist for the data
    get_varlabels = function(variables = NULL) {
      checkmate::assert_character(variables, null.ok = TRUE, any.missing = FALSE)

      labels <- formatters::var_labels(private$dataset, fill = FALSE)
      if (is.null(labels)) {
        return(NULL)
      }
      if (!is.null(variables)) labels <- labels[intersect(self$get_varnames(), variables)]
      labels
    },

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

    #' @description
    #' Gets variable names from dataset
    #' @return `character` the variable names
    get_varnames = function() {
      colnames(self$get_dataset())
    },

    #' @description
    #' Gets variable names for the filtering.
    #'
    #' It takes the intersection of the column names
    #' of the data and `private$filterable_varnames` if
    #' `private$filterable_varnames` has positive length
    #'
    #' @return (`character` vector) of variable names
    get_filterable_varnames = function() {
      varnames <- get_supported_filter_varnames(self)
      if (length(private$filterable_varnames) > 0) {
        return(intersect(private$filterable_varnames, varnames))
      }
      return(varnames)
    },

    # setters ------
    #' @description
    #' Set the allowed filterable variables
    #' @param varnames (`character` or `NULL`) The variables which can be filtered
    #' See `self$get_filterable_varnames` for more details
    #'
    #' @details When retrieving the filtered variables only
    #' those which have filtering supported (i.e. are of the permitted types)
    #' are included.
    #'
    #' @return invisibly this `FilteredDataset`
    set_filterable_varnames = function(varnames) {
      checkmate::assert_character(varnames, any.missing = FALSE, null.ok = TRUE)
      private$filterable_varnames <- varnames
      return(invisible(self))
    },

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

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

    #' @description
    #' Server module for a dataset active filters
    #'
    #' Server module managing a  active filters.
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @return `moduleServer` function which returns `NULL`
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          dataname <- self$get_dataname()
          logger::log_trace("FilteredDataset$server initializing, dataname: { dataname }")
          checkmate::assert_string(dataname)
          shiny::setBookmarkExclude("remove_filters")

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

          lapply(
            names(self$get_filter_states()),
            function(x) {
              self$get_filter_states(id = x)$server(id = x)
            }
          )

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

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

          observeEvent(input$remove_filters, {
            logger::log_trace("FilteredDataset$server@1 removing filters, dataname: { dataname }")
            lapply(
              self$get_filter_states(),
              function(x) x$state_list_empty()
            )
            logger::log_trace("FilteredDataset$server@1 removed filters, dataname: { dataname }")
          })

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

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

    #' @description
    #' Server module to add filter variable for this dataset
    #'
    #' Server module to add filter variable for this dataset
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param ... ignored
    #' @return `moduleServer` function.
    srv_add_filter_state = function(id, ...) {
      check_ellipsis(..., stop = FALSE)
      moduleServer(
        id = id,
        function(input, output, session) {
          stop("Pure virtual method")
        }
      )
    }
  ),
  ## __Private Fields ====
  private = list(
    dataset = NULL,
    filter_states = list(),
    dataname = character(0),
    keys = character(0),
    label = character(0),
    metadata = NULL,

    # if this has length > 0 then only varnames in this vector
    # can be filtered
    filterable_varnames = NULL,

    # Adds `FilterStates` to the `private$filter_states`.
    # `FilterStates` is added once for each element of the dataset.
    # @param filter_states (`FilterStates`)
    # @param id (`character(1)`)
    add_filter_states = function(filter_states, id) {
      stopifnot(is(filter_states, "FilterStates"))
      checkmate::assert_string(id)

      x <- setNames(list(filter_states), id)
      private$filter_states <- c(self$get_filter_states(), x)
    },

    # @description
    # Checks if the dataname exists and
    # (if provided) that varname is a valid column in the dataset
    #
    # Stops when this is not the case.
    #
    # @param varname (`character`) column within the dataset;
    #   if `NULL`, this check is not performed
    check_data_varname_exists = function(varname = NULL) {
      checkmate::assert_string(varname, null.ok = TRUE)

      isolate({
        if (!is.null(varname) && !(varname %in% self$get_varnames())) {
          stop(
            sprintf("variable '%s' does not exist in data '%s'", varname, dataname)
          )
        }
      })

      return(invisible(NULL))
    }
  )
)

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

#' @keywords internal
#' @export
init_filtered_data.TealData <- function(x, # nolint
                                        join_keys = x$get_join_keys(),
                                        code = x$get_code_class(),
                                        cdisc = FALSE,
                                        check = x$get_check()) {
  cdisc <- length(join_keys$get_parents()) > 0
  data_objects <- lapply(x$get_datanames(), function(dataname) {
    dataset <- x$get_dataset(dataname)

    parent <- if (cdisc) join_keys$get_parent(dataname) else NULL

    return_list <- list(
      dataset = dataset$get_raw_data(),
      keys = dataset$get_keys(),
      metadata = dataset$get_metadata(),
      label = dataset$get_dataset_label()
    )

    if (cdisc) return_list[["parent"]] <- parent
    return_list
  })

  names(data_objects) <- x$get_datanames()

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

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

  datasets <- if (cdisc) {
    CDISCFilteredData$new(x, join_keys = join_keys, code = code, check = check)
  } else {
    FilteredData$new(x, join_keys = join_keys, code = code, check = check)
  }
}

#' Validate dataset arguments
#'
#' Validate dataset arguments
#' @param dataset_args (`list`)\cr
#'   containing the arguments except (`dataname`)
#'   needed by `init_filtered_dataset`
#' @param dataname (`character(1)`)\cr
#'   the name of the `dataset` to be added to this object
#' @param allowed_parent (`logical(1)`)\cr
#'   whether `FilteredDataset` can have a parent - i.e. if it's a part of `CDISCFilteredData`
#' @keywords internal
#' @return (`NULL` or throws an error)
validate_dataset_args <- function(dataset_args, dataname, allowed_parent = FALSE) {
  check_simple_name(dataname)
  checkmate::assert_flag(allowed_parent)
  checkmate::assert_list(dataset_args, names = "unique")

  allowed_names <- c("dataset", "keys", "label", "metadata")
  if (allowed_parent) {
    allowed_names <- c(allowed_names, "parent")
  }

  checkmate::assert_subset(names(dataset_args), choices = allowed_names)

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

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


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

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

  shinyjs::runjs(expr)

  invisible(NULL)
}

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

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

  shinyjs::runjs(expr)

  invisible(NULL)
}

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

  # public methods ----
  public = list(
    #' @description Initializes `DFFilterStates` object.
    #'
    #' Initializes `DFFilterStates` object by setting `dataname`
    #'  and initializing `state_list` (`shiny::reactiveVal`).
    #' This class contains a single `state_list` with no specified name,
    #' which means that when calling the subset function associated with this class
    #' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`).
    #'
    #' @param dataname (`character(1)`)\cr
    #'   name of the data used in the \emph{subset expression}
    #'   specified to the function argument attached to this `FilterStates`
    #' @param datalabel (`character(0)` or `character(1)`)\cr
    #'   text label value
    #' @param varlabels (`character`)\cr
    #'   labels of the variables used in this object
    #' @param keys (`character`)\cr
    #'   key columns names
    #'
    initialize = function(dataname, datalabel, varlabels, keys) {
      super$initialize(dataname, datalabel)
      private$varlabels <- varlabels
      private$keys <- keys
      private$state_list <- list(
        reactiveVal()
      )
    },

    #' @description
    #' Returns a formatted string representing this `FilterStates` object.
    #'
    #' @param indent (`numeric(1)`) the number of spaces prepended to each line of the output
    #'
    #' @return `character(1)` the formatted string
    #'
    format = function(indent = 0) {
      checkmate::assert_number(indent, finite = TRUE, lower = 0)

      formatted_states <- vapply(
        self$state_list_get(1L), function(state) state$format(indent = indent),
        USE.NAMES = FALSE, FUN.VALUE = character(1)
      )
      paste(formatted_states, collapse = "\n")
    },

    #' @description
    #' Gets the name of the function used to filter the data in this `FilterStates`.
    #'
    #' Get name of  function used to create the \emph{subset expression}.
    #' For `DFFilterStates` this is `dplyr::filter`.
    #'
    #' @return `character(1)`
    get_fun = function() {
      "dplyr::filter"
    },

    #' @description
    #' Shiny server module.
    #'
    #' @param id (`character(1)`)\cr
    #'   shiny module instance id
    #'
    #' @return `moduleServer` function which returns `NULL`
    #'
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          previous_state <- reactiveVal(isolate(self$state_list_get(1L)))
          added_state_name <- reactiveVal(character(0))
          removed_state_name <- reactiveVal(character(0))

          observeEvent(self$state_list_get(1L), {
            added_state_name(setdiff(names(self$state_list_get(1L)), names(previous_state())))
            removed_state_name(setdiff(names(previous_state()), names(self$state_list_get(1L))))
            previous_state(self$state_list_get(1L))
          })

          observeEvent(added_state_name(), ignoreNULL = TRUE, {
            fstates <- self$state_list_get(1L)
            html_ids <- private$map_vars_to_html_ids(names(fstates))
            for (fname in added_state_name()) {
              private$insert_filter_state_ui(
                id = html_ids[fname],
                filter_state = fstates[[fname]],
                state_list_index = 1L,
                state_id = fname
              )
            }
            added_state_name(character(0))
          })

          observeEvent(removed_state_name(), {
            req(removed_state_name())
            for (fname in removed_state_name()) {
              private$remove_filter_state_ui(1L, fname, .input = input)
            }
            removed_state_name(character(0))
          })
          NULL
        }
      )
    },

    #' @description
    #' Gets the reactive values from the active `FilterState` objects.
    #'
    #' Get active filter state from the `FilterState` objects kept in `state_list`.
    #' The output list is a compatible input to `self$set_filter_state`.
    #'
    #' @return `list` with named elements corresponding to `FilterState` in the `state_list`.
    #'
    get_filter_state = function() {
      lapply(self$state_list_get(1L), function(x) x$get_state())
    },

    #' @description
    #' Set filter state.
    #'
    #' @param data (`data.frame`)\cr
    #'   data object for which to define a subset
    #' @param state (`named list`)\cr
    #'   should contain values of initial selections in the `FilterState`;
    #'   `list` names must correspond to column names in `data`
    #' @param vars_include (`character(n)`)\cr
    #'  optional, vector of column names to be included
    #' @param ... ignored
    #'
    #' @examples
    #' dffs <- teal.slice:::DFFilterStates$new(
    #'   dataname = "iris",
    #'   datalabel = character(0),
    #'   varlabels = character(0),
    #'   keys = character(0)
    #' )
    #' fs <- list(
    #'   Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE),
    #'   Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE)
    #' )
    #' shiny::isolate(dffs$set_filter_state(state = fs, data = iris))
    #' shiny::isolate(dffs$get_filter_state())
    #'
    #' @return `NULL`
    #'
    set_filter_state = function(data, state, vars_include = get_supported_filter_varnames(data = data), ...) {
      checkmate::assert_data_frame(data)
      checkmate::assert(
        checkmate::check_subset(names(state), names(data)),
        checkmate::check_class(state, "default_filter"),
        combine = "or"
      )
      logger::log_trace(
        "{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }"
      )

      filter_states <- self$state_list_get(1L)
      state_names <- names(state)
      excluded_vars <- setdiff(state_names, vars_include)
      if (length(excluded_vars) > 0) {
        warning(
          paste(
            "These columns filters were excluded:",
            paste(excluded_vars, collapse = ", "),
            "from dataset",
            private$dataname
          )
        )
        logger::log_warn(
          paste(
            "Columns filters { paste(excluded_vars, collapse = ', ') } were excluded",
            "from { private$dataname }"
          )
        )
      }

      filters_to_apply <- state_names[state_names %in% vars_include]

      for (varname in filters_to_apply) {
        value <- resolve_state(state[[varname]])
        if (varname %in% names(filter_states)) {
          fstate <- filter_states[[varname]]
          fstate$set_state(value)
        } else {
          fstate <- init_filter_state(
            data[[varname]],
            varname = varname,
            varlabel = private$get_varlabels(varname),
            dataname = private$dataname
          )
          fstate$set_state(value)
          self$state_list_push(x = fstate, state_list_index = 1L, state_id = varname)
        }
      }
      logger::log_trace(
        "{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }"
      )
      NULL
    },

    #' @description Remove a `FilterState` from the `state_list`.
    #'
    #' @param state_id (`character(1)`)\cr name of `state_list` element
    #'
    #' @return `NULL`
    #'
    remove_filter_state = function(state_id) {
      logger::log_trace(
        sprintf(
          "%s$remove_filter_state for variable %s called, dataname: %s",
          class(self)[1],
          state_id,
          private$dataname
        )
      )

      if (!state_id %in% names(self$state_list_get(1L))) {
        warning(paste(
          "Variable:", state_id,
          "is not present in the actual active filters of dataset: { private$dataname }",
          "therefore no changes are applied."
        ))
        logger::log_warn(
          paste(
            "Variable:", state_id, "is not present in the actual active filters of dataset:",
            "{ private$dataname } therefore no changes are applied."
          )
        )
      } else {
        self$state_list_remove(state_list_index = 1L, state_id = state_id)
        logger::log_trace(
          sprintf(
            "%s$remove_filter_state for variable %s done, dataname: %s",
            class(self)[1],
            state_id,
            private$dataname
          )
        )
      }
    },

    # shiny modules ----

    #' @description
    #' Shiny UI module to add filter variable.
    #'
    #' @param id (`character(1)`)\cr
    #'  shiny element (module instance) id
    #' @param data (`data.frame`)\cr
    #'  data object for which to define a subset
    #'
    #' @return `shiny.tag`
    #'
    ui_add_filter_state = function(id, data) {
      checkmate::assert_string(id)
      checkmate::assert_data_frame(data)

      ns <- NS(id)

      if (ncol(data) == 0) {
        div("no sample variables available")
      } else if (nrow(data) == 0) {
        div("no samples available")
      } else {
        div(
          teal.widgets::optionalSelectInput(
            ns("var_to_add"),
            choices = NULL,
            options = shinyWidgets::pickerOptions(
              liveSearch = TRUE,
              noneSelectedText = "Select variable to filter"
            )
          )
        )
      }
    },

    #' @description
    #' Shiny server module to add filter variable.
    #'
    #' This module controls available choices to select as a filter variable.
    #' Once selected, a variable is removed from available choices.
    #' Removing a filter variable adds it back to available choices.
    #'
    #' @param id (`character(1)`)\cr
    #'   shiny module instance id
    #' @param data (`data.frame`)\cr
    #'   data object for which to define a subset
    #' @param vars_include (`character(n)`)\cr
    #'  optional, vector of column names to be included
    #' @param ... ignored
    #'
    #' @return `moduleServer` function which returns `NULL`
    #'
    srv_add_filter_state = function(id, data, vars_include = get_supported_filter_varnames(data = data), ...) {
      stopifnot(is.data.frame(data))
      check_ellipsis(..., stop = FALSE)
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace(
            "DFFilterStates$srv_add_filter_state initializing, dataname: { private$dataname }"
          )
          shiny::setBookmarkExclude(c("var_to_add"))
          active_filter_vars <- reactive({
            vapply(
              X = self$state_list_get(state_list_index = 1L),
              FUN.VALUE = character(1),
              FUN = function(x) x$get_varname()
            )
          })

          # available choices to display
          avail_column_choices <- reactive({
            choices <- setdiff(vars_include, active_filter_vars())

            data_choices_labeled(
              data = data,
              choices = choices,
              varlabels = private$get_varlabels(choices),
              keys = private$keys
            )
          })
          observeEvent(
            avail_column_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_trace(paste(
                "DFFilterStates$srv_add_filter_state@1 updating available column choices,",
                "dataname: { private$dataname }"
              ))
              if (is.null(avail_column_choices())) {
                shinyjs::hide("var_to_add")
              } else {
                shinyjs::show("var_to_add")
              }
              teal.widgets::updateOptionalSelectInput(
                session,
                "var_to_add",
                choices = avail_column_choices()
              )
              logger::log_trace(paste(
                "DFFilterStates$srv_add_filter_state@1 updated available column choices,",
                "dataname: { private$dataname }"
              ))
            }
          )

          observeEvent(
            eventExpr = input$var_to_add,
            handlerExpr = {
              logger::log_trace(
                sprintf(
                  "DFFilterStates$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s",
                  input$var_to_add,
                  private$dataname
                )
              )
              self$state_list_push(
                x = init_filter_state(
                  data[[input$var_to_add]],
                  varname = input$var_to_add,
                  varlabel = private$get_varlabels(input$var_to_add),
                  dataname = private$dataname
                ),
                state_list_index = 1L,
                state_id = input$var_to_add
              )
              logger::log_trace(
                sprintf(
                  "DFFilterStates$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s",
                  input$var_to_add,
                  private$dataname
                )
              )
            }
          )

          logger::log_trace(
            "DFFilterStates$srv_add_filter_state initialized, dataname: { private$dataname }"
          )
          NULL
        }
      )
    }
  ),

  # private members ----
  private = list(
    varlabels = character(0),
    keys = character(0),
    # @description
    # Get label of specific variable. If variable label is missing, variable name is returned.
    #
    # @para variable (`character`)\cr
    #   name of variable for which label should be returned
    #
    # @return `character`
    get_varlabels = function(variables = character(0)) {
      checkmate::assert_character(variables)
      if (identical(variables, character(0))) {
        private$varlabels
      } else {
        varlabels <- private$varlabels[variables]
        missing_labels <- is.na(varlabels) | varlabels == ""
        varlabels[missing_labels] <- variables[missing_labels]
        varlabels
      }
    }
  )
)

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

  # public methods ----
  public = list(
    #' @description Initialize `MatrixFilterStates` object
    #'
    #' Initialize `MatrixFilterStates` object
    #'
    #' @param dataname (`character(1)`)\cr
    #'   name of the data used in the expression
    #'   specified to the function argument attached to this `FilterStates`.
    #'
    #' @param datalabel (`character(0)` or `character(1)`)\cr
    #'   text label value.
    initialize = function(dataname, datalabel) {
      super$initialize(dataname, datalabel)
      private$state_list <- list(
        subset = reactiveVal()
      )
    },

    #' @description
    #' Returns the formatted string representing this `MatrixFilterStates` object.
    #'
    #' @param indent (`numeric(1)`) the number of spaces before each line of the representation
    #' @return `character(1)` the formatted string
    format = function(indent = 0) {
      checkmate::assert_number(indent, finite = TRUE, lower = 0)

      formatted_states <- c()
      for (state in self$state_list_get(state_list_index = "subset")) {
        formatted_states <- c(formatted_states, state$format(indent = indent + 2))
      }
      paste(formatted_states, collapse = "\n")
    },

    #' @description
    #' Server module
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @return `moduleServer` function which returns `NULL`
    server = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          previous_state <- reactiveVal(isolate(self$state_list_get("subset")))
          added_state_name <- reactiveVal(character(0))
          removed_state_name <- reactiveVal(character(0))

          observeEvent(self$state_list_get("subset"), {
            added_state_name(
              setdiff(names(self$state_list_get("subset")), names(previous_state()))
            )
            removed_state_name(
              setdiff(names(previous_state()), names(self$state_list_get("subset")))
            )
            previous_state(self$state_list_get("subset"))
          })

          observeEvent(added_state_name(), ignoreNULL = TRUE, {
            fstates <- self$state_list_get("subset")
            html_ids <- private$map_vars_to_html_ids(keys = names(fstates))
            for (fname in added_state_name()) {
              private$insert_filter_state_ui(
                id = html_ids[fname],
                filter_state = fstates[[fname]],
                state_list_index = "subset",
                state_id = fname
              )
            }
            added_state_name(character(0))
          })

          observeEvent(removed_state_name(), {
            req(removed_state_name())

            for (fname in removed_state_name()) {
              private$remove_filter_state_ui("subset", fname, .input = input)
            }
            removed_state_name(character(0))
          })
          NULL
        }
      )
    },

    #' @description
    #' Returns active `FilterState` objects.
    #'
    #' Gets all active filters from this dataset in form of the nested list.
    #' The output list can be used as input to `self$set_filter_state`.
    #'
    #' @return `list` containing `list` with selected values for each `FilterState`.
    get_filter_state = function() {
      lapply(self$state_list_get(state_list_index = "subset"), function(x) x$get_state())
    },

    #' @description
    #' Sets a filter state
    #'
    #' @param data (`matrix`)\cr
    #'   data which are supposed to be filtered.
    #' @param state (`named list`)\cr
    #'   should contain values which are initial selection in the `FilterState`.
    #'   Names of the `list` element should correspond to the name of the
    #'   column in `data`.
    #' @param ... ignored.
    #' @return `NULL`
    set_filter_state = function(data, state, ...) {
      checkmate::assert_class(data, "matrix")
      checkmate::assert(
        checkmate::assert(
          !checkmate::test_null(names(state)),
          checkmate::check_subset(names(state), colnames(data)),
          combine = "and"
        ),
        checkmate::check_class(state, "default_filter"),
        combine = "or"
      )
      logger::log_trace(paste(
        "MatrixFilterState$set_filter_state initializing,",
        "dataname: { private$dataname }"
      ))
      filter_states <- self$state_list_get("subset")
      for (varname in names(state)) {
        value <- resolve_state(state[[varname]])
        if (varname %in% names(filter_states)) {
          fstate <- filter_states[[varname]]
          fstate$set_state(value)
        } else {
          fstate <- init_filter_state(
            data[, varname],
            varname = varname,
            varlabel = varname,
            dataname = private$dataname,
            extract_type = "matrix"
          )
          fstate$set_state(value)
          self$state_list_push(
            x = fstate,
            state_list_index = "subset",
            state_id = varname
          )
        }
      }
      logger::log_trace(paste(
        "MatrixFilterState$set_filter_state initialized,",
        "dataname: { private$dataname }"
      ))
      NULL
    },

    #' @description Remove a variable from the `state_list` and its corresponding UI element.
    #'
    #' @param state_id (`character(1)`)\cr name of `state_list` element.
    #'
    #' @return `NULL`
    remove_filter_state = function(state_id) {
      logger::log_trace(
        sprintf(
          "%s$remove_filter_state of variable %s, dataname: %s",
          class(self)[1],
          state_id,
          private$dataname
        )
      )

      if (!state_id %in% names(self$state_list_get("subset"))) {
        warning(paste(
          "Variable:", state_id, "is not present in the actual active filters of dataset:",
          "{ private$dataname } therefore no changes are applied."
        ))
        logger::log_warn(
          paste(
            "Variable:", state_id, "is not present in the actual active filters of dataset:",
            "{ private$dataname } therefore no changes are applied."
          )
        )
      } else {
        self$state_list_remove(state_list_index = "subset", state_id = state_id)
        logger::log_trace(
          sprintf(
            "%s$remove_filter_state of variable %s done, dataname: %s",
            class(self)[1],
            state_id,
            private$dataname
          )
        )
      }
    },

    # shiny modules ----

    #' @description
    #' Shiny UI module to add filter variable.
    #'
    #' @param id (`character(1)`)\cr
    #'   id of shiny module
    #' @param data (`matrix`)\cr
    #'   data object for which to define a subset
    #'
    #' @return `shiny.tag`
    #'
    ui_add_filter_state = function(id, data) {
      checkmate::assert_string(id)
      stopifnot(is.matrix(data))

      ns <- NS(id)

      if (ncol(data) == 0) {
        div("no sample variables available")
      } else if (nrow(data) == 0) {
        div("no samples available")
      } else {
        teal.widgets::optionalSelectInput(
          ns("var_to_add"),
          choices = NULL,
          options = shinyWidgets::pickerOptions(
            liveSearch = TRUE,
            noneSelectedText = "Select variable to filter"
          )
        )
      }
    },

    #' @description
    #' Shiny server module to add filter variable
    #'
    #' Module controls available choices to select as a filter variable.
    #' Selected filter variable is being removed from available choices.
    #' Removed filter variable gets back to available choices.
    #'
    #' @param id (`character(1)`)\cr
    #'   shiny module instance id
    #' @param data (`matrix`)\cr
    #'   data object for which to define a subset
    #' @param ... ignored
    #'
    #' @return `moduleServer` function which returns `NULL`
    #'
    srv_add_filter_state = function(id, data, ...) {
      stopifnot(is.matrix(data))
      check_ellipsis(..., stop = FALSE)
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace(
            "MatrixFilterStates$srv_add_filter_state initializing, dataname: { private$dataname }"
          )
          shiny::setBookmarkExclude("var_to_add")
          active_filter_vars <- reactive({
            vapply(
              X = self$state_list_get(state_list_index = "subset"),
              FUN.VALUE = character(1),
              FUN = function(x) x$get_varname()
            )
          })

          # available choices to display
          avail_column_choices <- reactive({
            choices <- setdiff(
              get_supported_filter_varnames(data = data),
              active_filter_vars()
            )
            data_choices_labeled(
              data = data,
              choices = choices,
              varlabels = character(0),
              keys = NULL
            )
          })
          observeEvent(
            avail_column_choices(),
            ignoreNULL = TRUE,
            handlerExpr = {
              logger::log_trace(paste(
                "MatrixFilterStates$srv_add_filter_state@1 updating column choices,",
                "dataname: { private$dataname }"
              ))
              if (length(avail_column_choices()) < 0) {
                shinyjs::hide("var_to_add")
              } else {
                shinyjs::show("var_to_add")
              }
              teal.widgets::updateOptionalSelectInput(
                session,
                "var_to_add",
                choices = avail_column_choices()
              )
              logger::log_trace(paste(
                "MatrixFilterStates$srv_add_filter_state@1 updated column choices,",
                "dataname: { private$dataname }"
              ))
            }
          )

          observeEvent(
            eventExpr = input$var_to_add,
            handlerExpr = {
              logger::log_trace(
                sprintf(
                  "MatrixFilterState$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s",
                  deparse1(input$var_to_add),
                  private$dataname
                )
              )
              self$state_list_push(
                x = init_filter_state(
                  subset(data, select = input$var_to_add),
                  varname = input$var_to_add,
                  varlabel = private$get_varlabel(input$var_to_add),
                  dataname = private$dataname,
                  extract_type = "matrix"
                ),
                state_list_index = "subset",
                state_id = input$var_to_add
              )
              logger::log_trace(
                sprintf(
                  "MatrixFilterState$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s",
                  deparse1(input$var_to_add),
                  private$dataname
                )
              )
            }
          )

          logger::log_trace(
            "MatrixFilterStates$srv_add_filter_state initialized, dataname: { private$dataname }"
          )
          NULL
        }
      )
    }
  )
)

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

  # public methods ----
  public = list(

    #' @description
    #' Initialize a `FilterState` object
    #' @param x (`numeric`)\cr
    #'   values of the variable used in filter
    #' @param varname (`character`, `name`)\cr
    #'   name of the variable
    #' @param varlabel (`character(1)`)\cr
    #'   label of the variable (optional).
    #' @param dataname (`character(1)`)\cr
    #'   optional name of dataset where `x` is taken from
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by dataname. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    initialize = function(x,
                          varname,
                          varlabel = character(0),
                          dataname = NULL,
                          extract_type = character(0)) {
      checkmate::assert_numeric(x, all.missing = FALSE)
      if (!any(is.finite(x))) stop("\"x\" contains no finite values")

      super$initialize(x, varname, varlabel, dataname, extract_type)
      private$inf_count <- sum(is.infinite(x))
      private$is_integer <- checkmate::test_integerish(x)
      private$keep_inf <- reactiveVal(FALSE)

      x_range <- range(x, finite = TRUE)
      x_pretty <- pretty(x_range, 100L)

      if (identical(diff(x_range), 0)) {
        private$set_choices(x_range)
        private$slider_ticks <- signif(x_range, digits = 10)
        private$slider_step <- NULL
        self$set_selected(x_range)
      } else {
        private$set_choices(range(x_pretty))
        private$slider_ticks <- signif(x_pretty, digits = 10)
        private$slider_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10)
        self$set_selected(range(x_pretty))
      }

      private$histogram_data <- if (sum(is.finite(x)) >= 2) {
        as.data.frame(
          stats::density(x, na.rm = TRUE, n = 100)[c("x", "y")] # 100 bins only
        )
      } else {
        data.frame(x = NA_real_, y = NA_real_)
      }

      return(invisible(self))
    },

    #' @description
    #' Returns a formatted string representing this `RangeFilterState`.
    #'
    #' @param indent (`numeric(1)`)
    #'        the number of spaces before after each new line character of the formatted string.
    #'        Default: 0
    #' @return `character(1)` the formatted string
    #'
    format = function(indent = 0) {
      checkmate::assert_number(indent, finite = TRUE, lower = 0)

      vals <- self$get_selected()
      sprintf(
        "%sFiltering on: %s\n%1$s  Selected range: %s - %s\n%1$s  Include missing values: %s",
        format("", width = indent),
        private$varname,
        format(vals[1], nsmall = 3),
        format(vals[2], nsmall = 3),
        format(self$get_keep_na())
      )
    },

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

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For this class returned call looks like
    #' `<varname> >= <min value> & <varname> <= <max value>` with
    #' optional `is.na(<varname>)` and `is.finite(<varname>)`.
    #' @return (`call`)
    get_call = function() {
      filter_call <-
        call(
          "&",
          call(">=", private$get_varname_prefixed(), self$get_selected()[1L]),
          call("<=", private$get_varname_prefixed(), self$get_selected()[2L])
        )
      private$add_keep_na_call(private$add_keep_inf_call(filter_call))
    },

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

    #' @description
    #' Returns the filtering state.
    #'
    #' @return `list` containing values taken from the reactive fields:
    #' * `selected` (`numeric(2)`) range of the filter.
    #' * `keep_na` (`logical(1)`) whether `NA` should be kept.
    #' * `keep_inf` (`logical(1)`)  whether `Inf` should be kept.
    get_state = function() {
      list(
        selected = self$get_selected(),
        keep_na = self$get_keep_na(),
        keep_inf = self$get_keep_inf()
      )
    },

    #' @description
    #' Set if `Inf` should be kept
    #' @param value (`logical(1)`)\cr
    #'  Value(s) which come from the filter selection. Value is set in `server`
    #'  modules after selecting check-box-input in the shiny interface. Values are set to
    #'  `private$keep_inf` which is reactive.
    set_keep_inf = function(value) {
      checkmate::assert_flag(value)
      private$keep_inf(value)
      logger::log_trace(
        sprintf(
          "%s$set_keep_inf of variable %s set to %s, dataname: %s.",
          class(self)[1],
          private$varname,
          value,
          private$dataname
        )
      )
    },

    #' @description
    #' Set state
    #' @param state (`list`)\cr
    #'  contains fields relevant for a specific class
    #' \itemize{
    #' \item{`selected`}{ defines initial selection}
    #' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
    #' \item{`keep_inf` (`logical`)}{ defines whether to keep or remove `Inf` values}
    #' }
    set_state = function(state) {
      stopifnot(is.list(state) && all(names(state) %in% c("selected", "keep_na", "keep_inf")))
      if (!is.null(state$keep_inf)) {
        self$set_keep_inf(state$keep_inf)
      }
      super$set_state(state[names(state) %in% c("selected", "keep_na")])
      invisible(NULL)
    },

    #' @description
    #' Sets the selected values of this `RangeFilterState`.
    #'
    #' @param value (`numeric(2)`) the two-elements array of the lower and upper bound
    #'   of the selected range. Must not contain NA values.
    #'
    #' @returns invisibly `NULL`
    #'
    #' @note Casts the passed object to `numeric` before validating the input
    #' making it possible to pass any object coercible to `numeric` to this method.
    #'
    #' @examples
    #' filter <- teal.slice:::RangeFilterState$new(c(1, 2, 3, 4), varname = "name")
    #' filter$set_selected(c(2, 3))
    #'
    set_selected = function(value) {
      super$set_selected(value)
    }
  ),

  # private fields----
  private = list(
    histogram_data = data.frame(),
    keep_inf = NULL, # because it holds reactiveVal
    inf_count = integer(0),
    is_integer = logical(0),
    slider_step = numeric(0), # step for the slider input widget, calculated from input data (x)
    slider_ticks = numeric(0), # allowed values for the slider input widget, calculated from input data (x)

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

    # @description gets pretty step size for range slider
    #  adaptation of shiny's method (see shiny/R/input-slider.R function findStepSize)
    # @param pretty_range (numeric(n)) vector of pretty values
    # @return numeric(1) pretty step size for the sliderInput
    get_pretty_range_step = function(pretty_range) {
      if (private$is_integer && diff(range(pretty_range) > 2)) {
        return(1L)
      } else {
        n_steps <- length(pretty_range) - 1
        return(
          signif(digits = 10, (max(pretty_range) - min(pretty_range)) / n_steps)
        )
      }
    },

    # overwrites superclass method
    validate_selection = function(value) {
      if (!is.numeric(value)) {
        stop(
          sprintf(
            "value of the selection for `%s` in `%s` should be a numeric",
            self$get_varname(),
            self$get_dataname()
          )
        )
      }
      invisible(NULL)
    },

    # overwrites superclass method
    # additionally adjusts progtammatic selection to existing slider ticks
    cast_and_validate = function(values) {
      if (!is.atomic(values)) stop("Values to set must be an atomic vector.")
      values <- as.numeric(values)
      if (any(is.na(values))) stop("The array of set values must contain values coercible to numeric.")
      if (length(values) != 2) stop("The array of set values must have length two.")

      values_adjusted <- contain_interval(values, private$slider_ticks)
      if (!isTRUE(all.equal(values, values_adjusted))) {
        logger::log_warn(sprintf(
          paste(
            "Programmatic range specification on %s was adjusted to existing slider ticks.",
            "It is now broader in order to contain the specified values."
          ),
          private$varname
        ))
      }
      values_adjusted
    },
    # for numeric ranges selecting out of bound values is allowed
    remove_out_of_bound_values = function(values) {
      values
    },

    # shiny modules ----

    # UI Module for `RangeFilterState`.
    # This UI element contains two values for `min` and `max`
    # of the range and two checkboxes whether to keep the `NA` or `Inf`  values.
    # @param id (`character(1)`)\cr
    #  id of shiny element
    ui_inputs = function(id) {
      ns <- NS(id)
      fluidRow(
        div(
          class = "filterPlotOverlayRange",
          plotOutput(ns("plot"), height = "100%")
        ),
        div(
          class = "filterRangeSlider",
          teal.widgets::optionalSliderInput(
            inputId = ns("selection"),
            label = NULL,
            min = private$choices[1],
            max = private$choices[2],
            value = isolate(private$selected()),
            step = private$slider_step,
            width = "100%"
          )
        ),
        private$keep_inf_ui(ns("keep_inf")),
        private$keep_na_ui(ns("keep_na"))
      )
    },

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

          output$plot <- renderPlot(
            bg = "transparent",
            height = 25,
            expr = {
              ggplot2::ggplot(private$histogram_data) +
                ggplot2::aes_string(x = "x", y = "y") +
                ggplot2::geom_area(
                  fill = grDevices::rgb(66 / 255, 139 / 255, 202 / 255),
                  color = NA,
                  alpha = 0.2
                ) +
                ggplot2::theme_void() +
                ggplot2::scale_y_continuous(expand = c(0, 0)) +
                ggplot2::scale_x_continuous(expand = c(0, 0))
            }
          )

          # this observer is needed in the situation when private$selected has been
          # changed directly by the api - then it's needed to rerender UI element
          # to show relevant values
          private$observers$selection_api <- observeEvent(
            ignoreNULL = FALSE,
            ignoreInit = TRUE,
            eventExpr = self$get_selected(),
            handlerExpr = {
              if (!isTRUE(all.equal(input$selection, self$get_selected()))) {
                updateSliderInput(
                  session = session,
                  inputId = "selection",
                  value = private$selected()
                )
              }
            }
          )

          private$observers$selection <- observeEvent(
            ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in `selectInput`
            ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
            eventExpr = input$selection,
            handlerExpr = {
              if (!isTRUE(all.equal(input$selection, self$get_selected()))) {
                self$set_selected(input$selection)
              }
              logger::log_trace(
                sprintf(
                  "RangeFilterState$server@3 selection of variable %s changed, dataname: %s",
                  private$varname,
                  private$dataname
                )
              )
            }
          )

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

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

    # @description
    # module displaying input to keep or remove Inf in the FilterState call
    # @param id `shiny` id parameter
    #  renders checkbox input only when variable from which FilterState has
    #  been created has some Inf values.
    keep_inf_ui = function(id) {
      ns <- NS(id)
      if (private$inf_count > 0) {
        checkboxInput(
          ns("value"),
          sprintf("Keep Inf (%s)", private$inf_count),
          value = self$get_keep_inf()
        )
      } else {
        NULL
      }
    },

    # @description
    # module to handle Inf values in the FilterState
    # @param shiny `id` parametr passed to moduleServer
    #  module sets `private$keep_inf` according to the selection.
    #  Module also updates a UI element if the `private$keep_inf` has been
    #  changed through the api
    keep_inf_srv = function(id) {
      moduleServer(id, function(input, output, session) {
        # this observer is needed in the situation when private$keep_na has been
        # changed directly by the api - then it's needed to rerender UI element
        # to show relevant values
        private$observers$keep_inf_api <- observeEvent(
          ignoreNULL = TRUE, # its not possible for range that NULL is selected
          ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
          eventExpr = self$get_keep_inf(),
          handlerExpr = {
            if (!setequal(self$get_keep_inf(), input$value)) {
              updateCheckboxInput(
                inputId = "value",
                value = self$get_keep_inf()
              )
            }
          }
        )
        private$observers$keep_inf <- observeEvent(
          ignoreNULL = TRUE, # it's not possible for range that NULL is selected
          ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
          eventExpr = input$value,
          handlerExpr = {
            keep_inf <- input$value
            self$set_keep_inf(keep_inf)
            logger::log_trace(
              sprintf(
                "%s$server keep_inf of variable %s set to: %s, dataname: %s",
                class(self)[1],
                private$varname,
                deparse1(input$value),
                private$dataname
              )
            )
          }
        )
        invisible(NULL)
      })
    }
  )
)

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

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `FilterState` object. This class
    #' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by
    #' default. However, in case when using this module in `teal` app, one needs
    #' timezone of the app user. App user timezone is taken from `session$userData$timezone`
    #' and is set only if object is initialized in `shiny`.
    #' @param x (`POSIXct` or `POSIXlt`)\cr
    #'   values of the variable used in filter
    #' @param varname (`character`, `name`)\cr
    #'   name of the variable
    #' @param varlabel (`character(1)`)\cr
    #'   label of the variable (optional).
    #' @param dataname (`character(1)`)\cr
    #'   optional name of dataset where `x` is taken from
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by dataname. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    initialize = function(x,
                          varname,
                          varlabel = character(0),
                          dataname = NULL,
                          extract_type = character(0)) {
      checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
      super$initialize(x, varname, varlabel, dataname, extract_type)

      var_range <- as.POSIXct(trunc(range(x, na.rm = TRUE), units = "secs"))
      private$set_choices(var_range)
      self$set_selected(var_range)

      return(invisible(self))
    },

    #' @description
    #' Returns a formatted string representing this `DatetimeFilterState`.
    #'
    #' @param indent (`numeric(1)`) the number of spaces before after each new line character of the formatted string.
    #' Default: 0
    #' @return `character(1)` the formatted string
    #'
    format = function(indent = 0) {
      checkmate::assert_number(indent, finite = TRUE, lower = 0)


      vals <- self$get_selected()
      sprintf(
        "%sFiltering on: %s\n%1$s  Selected range: %s - %s\n%1$s  Include missing values: %s",
        format("", width = indent),
        private$varname,
        format(vals[1], nsmall = 3),
        format(vals[2], nsmall = 3),
        format(self$get_keep_na())
      )
    },

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

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

    #' @description
    #' Sets the selected time frame of this `DatetimeFilterState`.
    #'
    #' @param value (`POSIX(2)`) the lower and the upper bound of the selected
    #'   time frame. Must not contain NA values.
    #'
    #' @return invisibly `NULL`.
    #'
    #' @note Casts the passed object to `POSIXct` before validating the input
    #' making it possible to pass any object coercible to `POSIXct` to this method.
    #'
    #' @examples
    #' date <- as.POSIXct(1, origin = "01/01/1970")
    #' filter <- teal.slice:::DatetimeFilterState$new(
    #'   c(date, date + 1, date + 2, date + 3),
    #'   varname = "name"
    #' )
    #' filter$set_selected(c(date + 1, date + 2))
    set_selected = function(value) {
      super$set_selected(value)
    }
  ),

  # private members ----

  private = list(
    # private methods ----
    validate_selection = function(value) {
      if (!(is(value, "POSIXct") || is(value, "POSIXlt"))) {
        stop(
          sprintf(
            "value of the selection for `%s` in `%s` should be a POSIXct or POSIXlt",
            self$get_varname(),
            self$get_dataname()
          )
        )
      }

      pre_msg <- sprintf(
        "dataset '%s', variable '%s': ",
        self$get_dataname(),
        self$get_varname()
      )
      check_in_range(value, private$choices, pre_msg = pre_msg)
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.POSIXct(values)
          if (any(is.na(values))) stop()
        },
        error = function(error) stop("The array of set values must contain values coercible to POSIX.")
      )
      if (length(values) != 2) stop("The array of set values must have length two.")
      values
    },
    remove_out_of_bound_values = function(values) {
      if (values[1] < private$choices[1]) {
        warning(paste(
          "Value:", values[1], "is outside of the possible range for column", private$varname,
          "of dataset", private$dataname, "."
        ))
        values[1] <- private$choices[1]
      }

      if (values[2] > private$choices[2]) {
        warning(paste(
          "Value:", values[2], "is outside of the possible range for column", private$varname,
          "of dataset", private$dataname, "."
        ))
        values[2] <- private$choices[2]
      }
      values
    },

    # shiny modules ----

    # @description
    # UI Module for `DatetimeFilterState`.
    # This UI element contains two date-time selections for `min` and `max`
    # of the range and a checkbox whether to keep the `NA` values.
    # @param id (`character(1)`)\cr
    #  id of shiny element
    ui_inputs = function(id) {
      ns <- NS(id)
      div(
        div(
          class = "flex",
          actionButton(
            class = "date_reset_button",
            inputId = ns("start_date_reset"),
            label = NULL,
            icon = icon("fas fa-undo")
          ),
          div(
            class = "flex w-80 filter_datelike_input",
            div(class = "w-45 text-center", {
              x <- shinyWidgets::airDatepickerInput(
                inputId = ns("selection_start"),
                value = self$get_selected()[1],
                startView = self$get_selected()[1],
                timepicker = TRUE,
                minDate = private$choices[1],
                maxDate = private$choices[2],
                update_on = "close",
                addon = "none",
                position = "bottom right"
              )
              x$children[[2]]$attribs <- c(x$children[[2]]$attribs, list(class = "input-sm"))
              x
            }),
            span(
              class = "input-group-addon w-10",
              span(class = "input-group-text w-100 justify-content-center", "to"),
              title = "Times are displayed in the local timezone and are converted to UTC in the analysis"
            ),
            div(class = "w-45 text-center", {
              x <- shinyWidgets::airDatepickerInput(
                inputId = ns("selection_end"),
                value = self$get_selected()[2],
                startView = self$get_selected()[2],
                timepicker = TRUE,
                minDate = private$choices[1],
                maxDate = private$choices[2],
                update_on = "close",
                addon = "none",
                position = "bottom right"
              )
              x$children[[2]]$attribs <- c(x$children[[2]]$attribs, list(class = "input-sm"))
              x
            })
          ),
          actionButton(
            class = "date_reset_button",
            inputId = ns("end_date_reset"),
            label = NULL,
            icon = icon("fas fa-undo")
          )
        ),
        private$keep_na_ui(ns("keep_na"))
      )
    },

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

          # this observer is needed in the situation when private$selected has been
          # changed directly by the api - then it's needed to rerender UI element
          # to show relevant values
          private$observers$selection_api <- observeEvent(
            ignoreNULL = TRUE, # dates needs to be selected
            ignoreInit = TRUE, # on init selected == default, so no need to trigger
            eventExpr = self$get_selected(),
            handlerExpr = {
              start_date <- input$selection_start
              end_date <- input$selection_end
              if (!all(self$get_selected() == c(start_date, end_date))) {
                if (self$get_selected()[1] != start_date) {
                  shinyWidgets::updateAirDateInput(
                    session = session,
                    inputId = "selection_start",
                    value = self$get_selected()[1]
                  )
                }

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

                logger::log_trace(sprintf(
                  "DatetimeFilterState$server@1 selection of variable %s changed, dataname: %s",
                  private$varname,
                  private$dataname
                ))
              }
            }
          )


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

              if (start_date < private$choices[1]) {
                start_date <- private$choices[1]
              }

              if (end_date > private$choices[2]) {
                end_date <- private$choices[2]
              }

              self$set_selected(c(start_date, end_date))
              logger::log_trace(sprintf(
                "DatetimeFilterState$server@2 selection of variable %s changed, dataname: %s",
                private$varname,
                private$dataname
              ))
            }
          )

          private$keep_na_srv("keep_na")

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

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

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `FilterState` object
    #' @param x (`character` or `factor`)\cr
    #'   values of the variable used in filter
    #' @param varname (`character`)\cr
    #'   name of the variable
    #' @param varlabel (`character(1)`)\cr
    #'   label of the variable (optional).
    #' @param dataname (`character(1)`)\cr
    #'   optional name of dataset where `x` is taken from
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by dataname. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    initialize = function(x,
                          varname,
                          varlabel = character(0),
                          dataname = NULL,
                          extract_type = character(0)) {
      checkmate::assert(
        is.character(x),
        is.factor(x),
        length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
        combine = "or"
      )
      super$initialize(x, varname, varlabel, dataname, extract_type)

      private$data_class <- class(x)[1L]
      if (inherits(x, "POSIXt")) {
        private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))
      }

      if (!is.factor(x)) {
        x <- factor(as.character(x), levels = as.character(sort(unique(x))))
      }
      x <- droplevels(x)
      tbl <- table(x)
      choices <- names(tbl)
      names(choices) <- tbl


      private$set_choices(as.list(choices))
      self$set_selected(unname(choices))
      private$histogram_data <- data.frame(
        x = levels(x),
        y = tabulate(x)
      )

      return(invisible(self))
    },

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

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For this class returned call looks like
    #' `<varname> %in%  c(<values selected>)` with
    #' optional `is.na(<varname>)`.
    #' @return (`call`)
    get_call = function() {
      varname <- private$get_varname_prefixed()
      choices <- self$get_selected()
      if (private$data_class != "factor") {
        choices <- do.call(sprintf("as.%s", private$data_class), list(x = choices))
      }
      fun_compare <- if (length(choices) == 1L) "==" else "%in%"
      filter_call <-
        if (inherits(choices, "Date")) {
          call(fun_compare, varname, call("as.Date", as.character(choices)))
        } else if (inherits(choices, c("POSIXct", "POSIXlt"))) {
          class <- class(choices)[1L]
          date_fun <- as.name(switch(class,
            "POSIXct" = "as.POSIXct",
            "POSIXlt" = "as.POSIXlt"
          ))
          call(fun_compare, varname, as.call(list(date_fun, as.character(choices), tz = private$tzone)))
        } else {
          # This handles numerics, characters, and factors.
          call(fun_compare, varname, choices)
        }
      private$add_keep_na_call(filter_call)
    },

    #' @description
    #' Set state
    #' @param state (`list`)\cr
    #'  contains fields relevant for a specific class
    #' \itemize{
    #' \item{`selected`}{ defines initial selection}
    #' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
    #' }
    set_state = function(state) {
      if (!is.null(state$selected)) {
        state$selected <- as.character(state$selected)
      }
      super$set_state(state)
      invisible(NULL)
    },

    #' @description
    #' Sets the selected values of this `ChoicesFilterState`.
    #'
    #' @param value (`character`) the array of the selected choices.
    #'   Must not contain NA values.
    #'
    #' @return invisibly `NULL`
    #'
    #' @note Casts the passed object to `character` before validating the input
    #' making it possible to pass any object coercible to `character` to this method.
    #'
    #' @examples
    #' filter <- teal.slice:::ChoicesFilterState$new(c("a", "b", "c"), varname = "name")
    #' filter$set_selected(c("c", "a"))
    set_selected = function(value) {
      super$set_selected(value)
    }
  ),

  # private members ----

  private = list(
    histogram_data = data.frame(),
    data_class = character(0), # stores class of filtered variable so that it can be restored in $get_call
    tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call

    # private methods ----
    validate_selection = function(value) {
      if (!is.character(value)) {
        stop(
          sprintf(
            "Values of the selection for `%s` in `%s` should be an array of character.",
            self$get_varname(),
            self$get_dataname()
          )
        )
      }
      pre_msg <- sprintf(
        "data '%s', variable '%s': ",
        self$get_dataname(),
        self$get_varname()
      )
      check_in_subset(value, private$choices, pre_msg = pre_msg)
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.character(values)
          if (any(is.na(values))) stop()
        },
        error = function(error) stop("The array of set values must contain values coercible to character.")
      )
      values
    },
    remove_out_of_bound_values = function(values) {
      in_choices_mask <- values %in% private$choices
      if (length(values[!in_choices_mask]) > 0) {
        warning(paste(
          "Values:", strtrim(paste(values[!in_choices_mask], collapse = ", "), 360),
          "are not in choices of column", private$varname, "in dataset", private$dataname, "."
        ))
      }
      values[in_choices_mask]
    },

    # shiny modules ----

    # @description
    # UI Module for `ChoicesFilterState`.
    # This UI element contains available choices selection and
    # checkbox whether to keep or not keep the `NA` values.
    # @param id (`character(1)`)\cr
    #  id of shiny element
    ui_inputs = function(id) {
      ns <- NS(id)
      div(
        if (length(private$choices) <= getOption("teal.threshold_slider_vs_checkboxgroup")) {
          l_counts <- as.numeric(names(private$choices))
          l_counts[is.na(l_counts)] <- 0
          l_freqs <- l_counts / sum(l_counts)
          labels <- lapply(seq_along(private$choices), function(i) {
            div(
              class = "choices_state_label",
              style = sprintf("width:%s%%", l_freqs[i] * 100),
              span(
                class = "choices_state_label_text",
                sprintf(
                  "%s (%s)",
                  private$choices[i],
                  l_counts[i]
                )
              )
            )
          })
          div(
            class = "choices_state",
            checkboxGroupInput(
              ns("selection"),
              label = NULL,
              selected = self$get_selected(),
              choiceNames = labels,
              choiceValues = as.character(private$choices),
              width = "100%"
            )
          )
        } else {
          teal.widgets::optionalSelectInput(
            inputId = ns("selection"),
            choices = stats::setNames(private$choices, sprintf("%s (%s)", private$choices, names(private$choices))),
            selected = self$get_selected(),
            multiple = TRUE,
            options = shinyWidgets::pickerOptions(
              actionsBox = TRUE,
              liveSearch = (length(private$choices) > 10),
              noneSelectedText = "Select a value"
            )
          )
        },
        private$keep_na_ui(ns("keep_na"))
      )
    },

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

          # this observer is needed in the situation when private$selected has been
          # changed directly by the api - then it's needed to rerender UI element
          # to show relevant values
          private$observers$selection_api <- observeEvent(
            ignoreNULL = FALSE, # it's possible that nothing is selected
            ignoreInit = TRUE,
            eventExpr = self$get_selected(),
            handlerExpr = {
              if (!setequal(self$get_selected(), input$selection)) {
                updateCheckboxInput(
                  session = session,
                  inputId = "selection",
                  value =  self$get_selected()
                )
                logger::log_trace(sprintf(
                  "ChoicesFilterState$server@1 selection of variable %s changed, dataname: %s",
                  private$varname,
                  private$dataname
                ))
              }
            }
          )

          private$observers$selection <- observeEvent(
            ignoreNULL = FALSE, # it's possible that nothing is selected
            ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
            eventExpr = input$selection,
            handlerExpr = {
              selection <- if (is.null(input$selection)) character(0) else input$selection
              self$set_selected(selection)
              logger::log_trace(sprintf(
                "ChoicesFilterState$server@2 selection of variable %s changed, dataname: %s",
                private$varname,
                private$dataname
              ))
            }
          )
          private$keep_na_srv("keep_na")

          logger::log_trace("ChoicesFilterState$server initialized, dataname: { private$dataname }")
          NULL
        }
      )
    }
  )
)

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

  # public methods ----
  public = list(

    #' @description
    #' Initialize a `FilterState` object
    #' @param x (`logical`)\cr
    #'   values of the variable used in filter
    #' @param varname (`character`, `name`)\cr
    #'   label of the variable (optional).
    #' @param varlabel (`character(1)`)\cr
    #'   label of the variable (optional).
    #' @param dataname (`character(1)`)\cr
    #'   optional name of dataset where `x` is taken from
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by dataname. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    initialize = function(x,
                          varname,
                          varlabel = character(0),
                          dataname = NULL,
                          extract_type = character(0)) {
      stopifnot(is.logical(x))
      super$initialize(x, varname, varlabel, dataname, extract_type)
      df <- as.factor(x)
      if (length(levels(df)) != 2) {
        if (levels(df) %in% c(TRUE, FALSE)) {
          choices_not_included <- c(TRUE, FALSE)[!c(TRUE, FALSE) %in% levels(df)]
          levels(df) <- c(levels(df), choices_not_included)
        }
      }

      tbl <- table(df)

      choices <- as.logical(names(tbl))
      names(choices) <- tbl
      private$set_choices(as.list(choices))
      self$set_selected(unname(choices)[1])
      private$histogram_data <- data.frame(
        x = sprintf(
          "%s (%s)",
          choices,
          names(choices)
        ),
        y = as.vector(tbl)
      )

      invisible(self)
    },

    #' @description
    #' Answers the question of whether the current settings and values selected actually filters out any values.
    #' @return logical scalar
    is_any_filtered = function() {
      if (!isTRUE(self$get_keep_na()) && private$na_count > 0) {
        TRUE
      } else if (all(private$histogram_data$y > 0)) {
        TRUE
      } else if (self$get_selected() == FALSE && "FALSE (0)" %in% private$histogram_data$x) {
        TRUE
      } else if (self$get_selected() == TRUE && "TRUE (0)" %in% private$histogram_data$x) {
        TRUE
      } else {
        FALSE
      }
    },

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally
    #' `is.na(<varname>)`
    get_call = function() {
      filter_call <-
        if (self$get_selected()) {
          private$get_varname_prefixed()
        } else {
          call("!", private$get_varname_prefixed())
        }
      private$add_keep_na_call(filter_call)
    },

    #' @description
    #' Sets the selected values of this `LogicalFilterState`.
    #'
    #' @param value (`logical(1)`)\cr
    #'  the value to set. Must not contain the NA value.
    #'
    #' @returns invisibly `NULL`.
    #'
    #' @note Casts the passed object to `logical` before validating the input
    #' making it possible to pass any object coercible to `logical` to this method.
    #'
    #' @examples
    #' filter <- teal.slice:::LogicalFilterState$new(c(TRUE), varname = "name")
    #' filter$set_selected(TRUE)
    set_selected = function(value) {
      super$set_selected(value)
    }
  ),

  # private fields ----

  private = list(
    histogram_data = data.frame(),

    # private methods ----

    validate_selection = function(value) {
      if (!(checkmate::test_logical(value, max.len = 1, any.missing = FALSE))) {
        stop(
          sprintf(
            "value of the selection for `%s` in `%s` should be a logical scalar (TRUE or FALSE)",
            self$get_varname(),
            self$get_dataname()
          )
        )
      }

      pre_msg <- sprintf(
        "dataset '%s', variable '%s': ",
        self$get_dataname(),
        self$get_varname()
      )
      check_in_subset(value, private$choices, pre_msg = pre_msg)
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values_logical <- as.logical(values)
          if (any(is.na(values_logical))) stop()
        },
        error = function(cond) stop("The array of set values must contain values coercible to logical.")
      )
      values_logical
    },

    # shiny modules ----

    # @description
    # UI Module for `EmptyFilterState`.
    # This UI element contains available choices selection and
    # checkbox whether to keep or not keep the `NA` values.
    # @param id (`character(1)`)\cr
    #  id of shiny element
    ui_inputs = function(id) {
      ns <- NS(id)
      l_counts <- as.numeric(names(private$choices))
      l_counts[is.na(l_counts)] <- 0
      l_freqs <- l_counts / sum(l_counts)
      labels <- lapply(seq_along(private$choices), function(i) {
        div(
          class = "choices_state_label",
          style = sprintf("width:%s%%", l_freqs[i] * 100),
          span(
            class = "choices_state_label_text",
            sprintf(
              "%s (%s)",
              private$choices[i],
              l_counts[i]
            )
          )
        )
      })
      div(
        div(
          class = "choices_state",
          radioButtons(
            ns("selection"),
            label = NULL,
            choiceNames = labels,
            choiceValues = as.character(private$choices),
            selected = as.character(self$get_selected()),
            width = "100%"
          )
        ),
        private$keep_na_ui(ns("keep_na"))
      )
    },

    # @description
    # Server module
    #
    # @param id (`character(1)`)\cr
    #   an ID string that corresponds with the ID used to call the module's UI function.
    # @return `moduleServer` function which returns `NULL`
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          # this observer is needed in the situation when private$selected has been
          # changed directly by the api - then it's needed to rerender UI element
          # to show relevant values
          private$observers$seleted_api <- observeEvent(
            ignoreNULL = TRUE, # this is radio button so something have to be selected
            ignoreInit = TRUE,
            eventExpr = self$get_selected(),
            handlerExpr = {
              if (!setequal(self$get_selected(), input$selection)) {
                updateRadioButtons(
                  session = session,
                  inputId = "selection",
                  selected =  self$get_selected()
                )
                logger::log_trace(sprintf(
                  "LogicalFilterState$server@1 selection of variable %s changed, dataname: %s",
                  private$varname,
                  private$dataname
                ))
              }
            }
          )

          private$observers$selection <- observeEvent(
            ignoreNULL = TRUE, # in radio button something has to be selected to input$selection can't be NULL
            ignoreInit = TRUE,
            eventExpr = input$selection,
            handlerExpr = {
              selection_state <- as.logical(input$selection)
              if (is.null(selection_state)) {
                selection_state <- logical(0)
              }
              self$set_selected(selection_state)
              logger::log_trace(
                sprintf(
                  "LogicalFilterState$server@2 selection of variable %s changed, dataname: %s",
                  private$varname,
                  private$dataname
                )
              )
            }
          )

          private$keep_na_srv("keep_na")

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

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

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

    #' @description
    #' Sets active filter states.
    #' @param filter (`named list`)\cr
    #' nested list of filter selections applied to datasets.
    #'
    #' @return `NULL`
    set_filter_state = function(filter) {
      if (private$filtered_data$get_filter_panel_active()) {
        private$filtered_data$set_filter_state(filter)
      } else {
        warning(private$deactivated_msg)
      }
      invisible(NULL)
    },

    #' @description
    #' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object.
    #' @param filter (`named list`)\cr
    #'  nested list of filter selections applied to datasets.
    #'
    #' @return `NULL`
    remove_filter_state = function(filter) {
      if (private$filtered_data$get_filter_panel_active()) {
        private$filtered_data$remove_filter_state(filter)
      } else {
        warning(private$deactivated_msg)
      }
      invisible(NULL)
    },

    #' @description Remove all `FilterStates` of the `FilteredData` object.
    #'
    #' @param datanames (`character`)\cr
    #'  datanames to remove their `FilterStates`;
    #'  omit to remove all `FilterStates` in the `FilteredData` object
    #'
    #' @return `NULL`
    #'
    remove_all_filter_states = function(datanames) {
      if (private$filtered_data$get_filter_panel_active()) {
        datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames
        private$filtered_data$remove_all_filter_states(datanames = datanames_to_remove)
      } else {
        warning(private$deactivated_msg)
      }
      invisible(NULL)
    },
    #' @description
    #' Toggle the state of the global Filter Panel button by running `javascript` code
    #' to click the toggle button with the `filter_panel_active` id suffix.
    #' The button id is prefixed with the Filter Panel shiny namespace.
    #' This button is observed in `srv_filter_panel` method that executes
    #' `filter_panel_enable()` or `filter_panel_disable()` method depending on the toggle state.
    #'
    #' @return `NULL`
    filter_panel_toggle = function() {
      shinyjs::runjs(
        sprintf(
          '$("#%s-filter_turn_onoff").click();',
          private$filtered_data$get_filter_panel_ui_id()
        )
      )
      invisible(NULL)
    }
  ),
  ## __Private Methods ====
  private = list(
    filtered_data = NULL,
    deactivated_msg = "Filter Panel is deactivated so the action can not be applied with api."
  )
)

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

  # public methods ----
  public = list(

    #' @description
    #' Initialize `MAEFilteredDataset` object
    #'
    #' @param dataset (`MulitiAssayExperiment`)\cr
    #'  a single `MultiAssayExperiment` for which to define a subset
    #' @param dataname (`character`)\cr
    #'  a given name for the dataset it may not contain spaces
    #' @param keys optional, (`character`)\cr
    #'   vector with primary keys
    #' @param label (`character`)\cr
    #'   label to describe the dataset
    #' @param metadata (named `list` or `NULL`) \cr
    #'   field containing metadata about the dataset;
    #'   each element of the list must be atomic and length one
    #'
    initialize = function(dataset, dataname, keys = character(0), label = character(0), metadata = NULL) {
      if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
        stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
      }
      checkmate::assert_class(dataset, "MultiAssayExperiment")
      super$initialize(dataset, dataname, keys, label, metadata)
      experiment_names <- names(dataset)

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

    #' @description
    #' Get filter expression
    #'
    #' This functions returns filter calls equivalent to selected items
    #' within each of `filter_states`. Configuration of the calls is constant and
    #' depends on `filter_states` type and order which are set during initialization.
    #' This class contains multiple `FilterStates`:
    #' \itemize{
    #'   \item{`colData(dataset)`}{for this object single `MAEFilterStates`
    #'   which returns `subsetByColData` call}
    #'   \item{experiments}{for each experiment single `SEFilterStates` and
    #'   `FilterStates_matrix`, both returns `subset` call}
    #' }
    #' @return filter `call` or `list` of filter calls
    get_call = function() {
      filter_call <- Filter(
        f = Negate(is.null),
        x = lapply(
          self$get_filter_states(),
          function(x) x$get_call()
        )
      )
      if (length(filter_call) == 0) {
        return(NULL)
      }
      filter_call
    },

    #' @description
    #' Gets labels of variables in the data
    #'
    #' Variables are the column names of the data.
    #' Either, all labels must have been provided for all variables
    #' in `set_data` or `NULL`.
    #'
    #' @param variables (`character` vector) variables to get labels for;
    #'   if `NULL`, for all variables in data
    #' @return (`character` or `NULL`) variable labels, `NULL` if `column_labels`
    #'   attribute does not exist for the data
    get_varlabels = function(variables = NULL) {
      checkmate::assert_character(variables, null.ok = TRUE, any.missing = FALSE)

      labels <- vapply(
        X = SummarizedExperiment::colData(private$dataset),
        FUN.VALUE = character(1),
        FUN = function(x) {
          label <- attr(x, "label")
          if (length(label) != 1) {
            NA_character_
          } else {
            label
          }
        }
      )

      if (is.null(labels)) {
        return(NULL)
      }
      if (!is.null(variables)) labels <- labels[names(labels) %in% variables]
      labels
    },

    #' @description
    #' Get filter overview rows of a dataset
    #' @param filtered_dataset (`MultiAssayExperiment`) object to calculate filter overview statistics on.
    #' @return (`matrix`) matrix of observations and subjects
    get_filter_overview_info = function(filtered_dataset = self$get_dataset()) {
      names_exps <- paste0("- ", names(self$get_dataset()))
      mae_and_exps <- c(self$get_dataname(), names_exps)

      df <- cbind(
        private$get_filter_overview_nobs(filtered_dataset),
        self$get_filter_overview_nsubjs(filtered_dataset)
      )

      rownames(df) <- mae_and_exps
      colnames(df) <- c("Obs", "Subjects")

      df
    },

    #' @description
    #' Gets variable names for the filtering.
    #'
    #' @return (`character(0)`)
    get_filterable_varnames = function() {
      character(0)
    },

    #' @description
    #' Set filter state
    #'
    #' @param state (`named list`)\cr
    #'  names of the list should correspond to the names of the initialized `FilterStates`
    #'  kept in `private$filter_states`. For this object they are `"subjects"` and
    #'  names of the experiments. Values of initial state should be relevant
    #'  to the referred column.
    #' @param ... ignored.
    #' @examples
    #' utils::data(miniACC, package = "MultiAssayExperiment")
    #' dataset <- teal.slice:::MAEFilteredDataset$new(miniACC, "MAE")
    #' fs <- list(
    #'   subjects = list(
    #'     years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE),
    #'     vital_status = list(selected = "1", keep_na = FALSE),
    #'     gender = list(selected = "female", keep_na = TRUE)
    #'   ),
    #'   RPPAArray = list(
    #'     subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE))
    #'   )
    #' )
    #' shiny::isolate(dataset$set_filter_state(state = fs))
    #' shiny::isolate(dataset$get_filter_state())
    #' @return `NULL`
    set_filter_state = function(state, ...) {
      checkmate::assert_list(state)
      checkmate::assert_subset(names(state), c(names(self$get_filter_states())))

      logger::log_trace(
        sprintf(
          "MAEFilteredDataset$set_filter_state setting up filters of variable %s, dataname: %s",
          paste(names(state), collapse = ", "),
          self$get_dataname()
        )
      )
      data <- self$get_dataset()
      for (fs_name in names(state)) {
        fs <- self$get_filter_states()[[fs_name]]
        fs$set_filter_state(
          state = state[[fs_name]],
          data = `if`(fs_name == "subjects", data, data[[fs_name]])
        )
      }

      logger::log_trace(
        sprintf(
          "MAEFilteredDataset$set_filter_state done setting filters of variable %s, dataname: %s",
          paste(names(state), collapse = ", "),
          self$get_dataname()
        )
      )
      NULL
    },

    #' @description Remove one or more `FilterState` of a `MAEFilteredDataset`
    #'
    #' @param state_id (`list`)\cr
    #'  Named list of variables to remove their `FilterState`.
    #'
    #' @return `NULL`
    #'
    remove_filter_state = function(state_id) {
      checkmate::assert_list(state_id, names = "unique")
      checkmate::assert_subset(names(state_id), c(names(self$get_filter_states())))

      logger::log_trace(
        sprintf(
          "MAEFilteredDataset$remove_filter_state removing filters of variable %s, dataname: %s",
          state_id,
          self$get_dataname()
        )
      )

      for (fs_name in names(state_id)) {
        fdata_filter_state <- self$get_filter_states()[[fs_name]]
        fdata_filter_state$remove_filter_state(
          `if`(fs_name == "subjects", state_id[[fs_name]][[1]], state_id[[fs_name]])
        )
      }
      logger::log_trace(
        sprintf(
          "MAEFilteredDataset$remove_filter_state done removing filters of variable %s, dataname: %s",
          state_id,
          self$get_dataname()
        )
      )
      invisible(NULL)
    },

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

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

    #' @description
    #' Server module to add filter variable for this dataset
    #'
    #' Server module to add filter variable for this dataset.
    #' For this class `srv_add_filter_state` calls multiple modules
    #' of the same name from `FilterStates` as `MAEFilteredDataset`
    #' contains one `FilterStates` object for `colData` and one for each
    #' experiment.
    #'
    #' @param id (`character(1)`)\cr
    #'   an ID string that corresponds with the ID used to call the module's UI function.
    #' @param ... ignored.
    #' @return `moduleServer` function which returns `NULL`
    srv_add_filter_state = function(id, ...) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace(paste(
            "MAEFilteredDataset$srv_add_filter_state initializing,",
            "dataname: { deparse1(self$get_dataname()) }"
          ))
          data <- self$get_dataset()
          self$get_filter_states("subjects")$srv_add_filter_state(
            id = "subjects",
            data = data # MultiAssayExperiment
            # ignoring vars_include
          )

          experiment_names <- names(data)
          lapply(
            experiment_names,
            function(experiment_name) {
              self$get_filter_states(experiment_name)$srv_add_filter_state(
                id = experiment_name,
                data = data[[experiment_name]] # SummarizedExperiment or matrix
                # ignoring vars_include
              )
            }
          )
          logger::log_trace(paste(
            "MAEFilteredDataset$srv_add_filter_state initialized,",
            "dataname: { deparse1(self$get_dataname()) }"
          ))
          NULL
        }
      )
    },

    #' @description
    #' Gets filter overview subjects number
    #' @param filtered_dataset (`MultiAssayExperiment`) object to calculate filter overview statistics on.
    #' @param subject_keys (unused) in `MultiAssayExperiment` unique subjects are the rows of `colData` slot.
    #' @return `list` with the number of subjects of filtered/non-filtered datasets.
    get_filter_overview_nsubjs = function(filtered_dataset = self$get_dataset(), subject_keys) {
      data_f <- filtered_dataset
      data_nf <- self$get_dataset()
      experiment_names <- names(data_nf)

      data_f_subjects_info <- nrow(SummarizedExperiment::colData(data_f))
      data_nf_subjects_info <- nrow(SummarizedExperiment::colData(data_nf))
      mae_total_subjects_info <- paste0(data_f_subjects_info, "/", data_nf_subjects_info)

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

      subjects_info <- lapply(
        experiment_names,
        function(experiment_name) {
          subjects_f_rows <- get_experiment_rows(data_f, data_f[[experiment_name]])
          subjects_nf_rows <- get_experiment_rows(data_nf, data_nf[[experiment_name]])

          subjects_info <- paste0(subjects_f_rows, "/", subjects_nf_rows)
          subjects_info
        }
      )

      append(
        list(mae_total_subjects_info),
        subjects_info
      )
    }
  ),

  # private members ----
  private = list(

    # Gets filter overview observations number and returns a
    # list of the number of observations of filtered/non-filtered datasets
    get_filter_overview_nobs = function(filtered_dataset) {
      data_f <- filtered_dataset
      data_nf <- self$get_dataset()
      experiment_names <- names(data_nf)
      mae_total_data_info <- ""

      data_info <- lapply(
        experiment_names,
        function(experiment_name) {
          data_f_rows <- ncol(data_f[[experiment_name]])
          data_nf_rows <- ncol(data_nf[[experiment_name]])

          data_info <- paste0(data_f_rows, "/", data_nf_rows)
          data_info
        }
      )

      append(
        list(mae_total_data_info),
        data_info
      )
    }
  )
)

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

  # public methods ----
  public = list(
    #' @description
    #' Initialize `EmptyFilterState` object.
    #'
    #' @param x (`vector`)\cr
    #'   values of the variable used in filter
    #' @param varname (`character`, `name`)\cr
    #'   name of the variable
    #' @param varlabel (`character(1)`)\cr
    #'   label of the variable (optional).
    #' @param dataname (`character(1)`)\cr
    #'   optional name of dataset where `x` is taken from
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #'   whether condition calls should be prefixed by dataname. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    #'
    initialize = function(x,
                          varname,
                          varlabel = character(0),
                          dataname = NULL,
                          extract_type = character(0)) {
      super$initialize(x, varname, varlabel, dataname, extract_type)
      private$set_choices(list())
      self$set_selected(list())

      return(invisible(self))
    },

    #' @description
    #' Reports whether the current state filters out any values.(?)
    #'
    #' @return `logical(1)`
    #'
    is_any_filtered = function() {
      !isTRUE(self$get_keep_na())
    },

    #' @description
    #' Returns reproducible condition call for current selection relevant
    #' for selected variable type.
    #' Uses internal reactive values, hence must be called
    #' in reactive or isolated context.
    #'
    #' @return `logical(1)`
    #'
    get_call = function() {
      filter_call <- if (isTRUE(self$get_keep_na())) {
        call("is.na", private$get_varname_prefixed())
      } else {
        FALSE
      }
    },

    #' @description
    #' Returns the filtering state.
    #'
    #' @return `list` containing values taken from the reactive fields:
    #' * `keep_na` (`logical(1)`) whether `NA` should be kept.
    #'
    get_state = function() {
      list(
        keep_na = self$get_keep_na()
      )
    },

    #' @description
    #' Set state.
    #'
    #' @param state (`list`)\cr
    #'  contains fields relevant for specific class:
    #' \itemize{
    #' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
    #' }
    #'
    #' @return NULL invisibly
    set_state = function(state) {
      if (!is.null(state$selected)) {
        stop(
          sprintf(
            "All values in variable '%s' are `NA`. Unable to apply filter values \n  %s",
            private$varname,
            paste(state$selected, collapse = ", ")
          )
        )
      }
      stopifnot(is.list(state) && all(names(state) == "keep_na"))
      if (!is.null(state$keep_na)) {
        self$set_keep_na(state$keep_na)
      }
      invisible(NULL)
    }
  ),

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

    # @description
    # Controls state of the `keep_na` checkbox input.
    #
    # @param id (`character(1)`)\cr
    #   shiny module instance id
    #
    # @return `moduleServer` function which returns `NULL`
    #
    server_inputs = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          private$keep_na_srv("keep_na")
        }
      )
    }
  )
)

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

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `FilterState` object
    #' @param x (`Date`)\cr
    #'   values of the variable used in filter
    #' @param varname (`character`, `name`)\cr
    #'   name of the variable
    #' @param varlabel (`character(1)`)\cr
    #'   label of the variable (optional).
    #' @param dataname (`character(1)`)\cr
    #'   optional name of dataset where `x` is taken from
    #' @param extract_type (`character(0)`, `character(1)`)\cr
    #' whether condition calls should be prefixed by dataname. Possible values:
    #' \itemize{
    #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
    #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
    #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
    #' }
    initialize = function(x,
                          varname,
                          varlabel = character(0),
                          dataname = NULL,
                          extract_type = character(0)) {
      stopifnot(is(x, "Date"))
      super$initialize(x, varname, varlabel, dataname, extract_type)

      var_range <- range(x, na.rm = TRUE)
      private$set_choices(var_range)
      self$set_selected(var_range)

      return(invisible(self))
    },

    #' @description
    #' Returns a formatted string representing this `DateFilterState`.
    #'
    #' @param indent (`numeric(1)`) the number of spaces before after each new line character of the formatted string.
    #' Default: 0
    #' @return `character(1)` the formatted string
    #'
    format = function(indent = 0) {
      checkmate::assert_number(indent, finite = TRUE, lower = 0)

      vals <- self$get_selected()
      sprintf(
        "%sFiltering on: %s\n%1$s  Selected range: %s - %s\n%1$s  Include missing values: %s",
        format("", width = indent),
        private$varname,
        format(vals[1], nsmall = 3),
        format(vals[2], nsmall = 3),
        format(self$get_keep_na())
      )
    },

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

    #' @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>)`.
    #' @return (`call`)
    get_call = function() {
      choices <- as.character(self$get_selected())
      filter_call <-
        call(
          "&",
          call(">=", private$get_varname_prefixed(), call("as.Date", choices[1L])),
          call("<=", private$get_varname_prefixed(), call("as.Date", choices[2L]))
        )
      private$add_keep_na_call(filter_call)
    },

    #' @description
    #' Sets the selected time frame of this `DateFilterState`.
    #'
    #' @param value (`Date(2)`) the lower and the upper bound of the selected
    #'   time frame. Must not contain NA values.
    #'
    #' @return invisibly `NULL`.
    #'
    #' @note Casts the passed object to `Date` before validating the input
    #' making it possible to pass any object coercible to `Date` to this method.
    #'
    #' @examples
    #' date <- as.Date("13/09/2021")
    #' filter <- teal.slice:::DateFilterState$new(
    #'   c(date, date + 1, date + 2, date + 3),
    #'   varname = "name"
    #' )
    #' filter$set_selected(c(date + 1, date + 2))
    set_selected = function(value) {
      super$set_selected(value)
    }
  ),

  # private methods ----

  private = list(
    validate_selection = function(value) {
      if (!is(value, "Date")) {
        stop(
          sprintf(
            "value of the selection for `%s` in `%s` should be a Date",
            self$get_varname(),
            self$get_dataname()
          )
        )
      }
      pre_msg <- sprintf(
        "dataset '%s', variable '%s': ",
        self$get_dataname(),
        self$get_varname()
      )
      check_in_range(value, private$choices, pre_msg = pre_msg)
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.Date(values)
          if (any(is.na(values))) stop()
        },
        error = function(error) stop("The array of set values must contain values coercible to Date.")
      )
      if (length(values) != 2) stop("The array of set values must have length two.")
      values
    },
    remove_out_of_bound_values = function(values) {
      if (values[1] < private$choices[1]) {
        warning(paste(
          "Value:", values[1], "is outside of the possible range for column", private$varname,
          "of dataset", private$dataname, "."
        ))
        values[1] <- private$choices[1]
      }

      if (values[2] > private$choices[2]) {
        warning(paste(
          "Value:", values[2], "is outside of the possible range for column", private$varname,
          "of dataset", private$dataname, "."
        ))
        values[2] <- private$choices[2]
      }
      values
    },

    # shiny modules ----

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

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

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

          private$observers$selection <- observeEvent(
            ignoreNULL = TRUE, # dates needs to be selected
            ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
            eventExpr = input$selection,
            handlerExpr = {
              start_date <- input$selection[1]
              end_date <- input$selection[2]

              self$set_selected(c(start_date, end_date))
              logger::log_trace(sprintf(
                "DateFilterState$server@2 selection of variable %s changed, dataname: %s",
                private$varname,
                private$dataname
              ))
            }
          )


          private$keep_na_srv("keep_na")

          private$observers$reset1 <- observeEvent(input$start_date_reset, {
            updateDateRangeInput(
              session = session,
              inputId = "selection",
              start = private$choices[1]
            )
            logger::log_trace(sprintf(
              "DateFilterState$server@3 reset start date of variable %s, dataname: %s",
              private$varname,
              private$dataname
            ))
          })

          private$observers$reset2 <- observeEvent(input$end_date_reset, {
            updateDateRangeInput(
              session = session,
              inputId = "selection",
              end = private$choices[2]
            )
            logger::log_trace(sprintf(
              "DateFilterState$server@4 reset end date of variable %s, dataname: %s",
              private$varname,
              private$dataname
            ))
          })
          logger::log_trace("DateFilterState$server initialized, dataname: { private$dataname }")
          NULL
        }
      )
    }
  )
)

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

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

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

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


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

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

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

  return(res)
}

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

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

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

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

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

  return(res)
}

#' Resolve list of filter states
#'
#' Resolves the state values for `FilterState$set_state()`, which accepts only a list
#' with `selected`,`keep_na` and `keep_inf` fields. In case of the `default_filter` function,
#' it returns `NULL` as during the initialization of `FilterState` values are set to
#' default.
#'
#' @param x (`list`,`vector`)\cr
#'  values of the variable used in filter. Depending on the `FilterState` type
#'  list must contain these fields:
#'  \itemize{
#'  \item{`selected`}{ defines initial selection. See notes for more details}
#'  \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
#'  \item{`keep_inf` (`logical`)}{ defines whether to keep or remove `Inf` values}
#'  }
#'  If `vector` is provided then `keep_na` and `keep_inf` can be specified
#'  adding `NA` and `Inf` to the selection vector.
#'
#' @note
#' The value of the `x$selected` needs to be modified according to the type
#' of the passed `filter_state`.
#'
#' @seealso
#' - [LogicalFilterState]
#' - [ChoicesFilterState]
#' - [RangeFilterState]
#' - [DateFilterState]
#' - [DatetimeFilterState]
#'
#' @return `list` containing `selected`, `keep_na` and `keep_inf`
#'
#' @keywords internal
#'
#' @examples
#' teal.slice:::resolve_state(list(c(1, 2), keep_na = FALSE, keep_inf = TRUE))
#' teal.slice:::resolve_state(c(1, 2, Inf))
#' teal.slice:::resolve_state(list())
resolve_state <- function(x) {
  UseMethod("resolve_state")
}

#' @rdname resolve_state
#' @keywords internal
#' @export
resolve_state.default <- function(x) {
  state <- list()
  if (length(x[!(is.infinite(x) | is.na(x))]) > 0) {
    state$selected <- x[!(is.infinite(x) | is.na(x))]
  }

  if (any(is.na(x))) {
    state$keep_na <- TRUE
  }

  if (any(is.infinite(x))) {
    state$keep_inf <- TRUE
  }

  state
}

#' @rdname resolve_state
#' @keywords internal
#' @export
resolve_state.default_filter <- function(x, filter_state) { # nolint
  list()
}

#' @rdname resolve_state
#' @keywords internal
#' @export
resolve_state.list <- function(x) {
  if (identical(x, list())) {
    return(x)
  }
  if (is.null(names(x))) {
    names(x) <- rep("", length(x))
  }
  x_names <- names(x)
  if (sum(x_names == "") > 1) {
    stop("More than one element of filter state is unnamed.")
  } else if (sum(x_names == "") == 1) {
    if ("selected" %in% x_names) {
      stop("Unnamed element of filter state cannot be intepreted as 'selected' because it already exists.")
    } else {
      x_idx <- which(x_names == "")
      names(x)[[x_idx]] <- "selected"
    }
  }
  x
}

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

#' Combine calls by operator
#'
#' Combine list of calls by specific operator
#'
#' @param calls (`list` of calls)\cr
#'   list containing calls to be combined by `operator`;
#'   if empty, NULL is returned
#' @param operator (`character(1)`)\cr
#'   name/symbol of the operator passed as character string
#'
#' @return call or NULL, if `calls` is an empty list
#'
#' @examples
#' \dontrun{
#' calls <- list(
#'   quote(SEX == "F"), # subsetting on factor
#'   quote(AGE >= 20 & AGE <= 50), # subsetting on range
#'   quote(!SURV) # subsetting on logical
#' )
#' calls_combine_by(calls, "&")
#' }
#' @return a combined `call`
#' @keywords internal
calls_combine_by <- function(calls, operator) {
  checkmate::assert_list(calls)
  if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
  checkmate::assert_string(operator)

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

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

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

  invisible()
}

#' Managing `FilteredData` states
#'
#' @description `r lifecycle::badge("experimental")`
#' Set, get and remove filter states of `FilteredData` object
#'
#' @name filter_state_api
#'
#' @param datasets (`FilteredData`)\cr
#'   object to store filter state and filtered datasets, shared across modules. For more
#'   details see [`FilteredData`]
#'
#' @param filter (`list`)\cr
#'   You can define filters that show when the app starts. List names should be
#'   named according to datanames passed to the `data` argument.
#'   In case of  data.frame` the list should be composed as follows:
#'   ```
#'   list(<dataname1> = list(<varname1> = ..., <varname2> = ...),
#'        <dataname2> = list(...),
#'        ...)
#'
#'   ```
#'
#'   For example, filters for variable `Sepal.Length` in `iris` can be specified as
#'   follows:
#'   ```
#'   list(iris = list(Sepal.Length = list(selected = c(5.0, 7.0))))
#'   # or
#'   list(iris = list(Sepal.Length = c(5.0, 7.0)))
#'   ```
#'
#'   In case developer would like to include `NA` and `Inf` values in  the
#'   filtered dataset.
#'   ```
#'   list(Species = list(selected = c(5.0, 7.0), keep_na = TRUE, keep_inf = TRUE))
#'   list(Species = c(c(5.0, 7.0), NA, Inf))
#'   ```
#'
#'   To initialize with specific variable filter with all values on start, one
#'   can use
#'   ```
#'   list(Species = list())
#'   ```
#'   `filter` should be set with respect to the class of the column:
#'   * `numeric`: `selected` should be a two elements vector defining the range
#'   of the filter.
#'   * `Date`: `selected` should be a two elements vector defining the date-range
#'   of the filter
#'   * `POSIXct`: `selected` should be a two elements vector defining the
#'   `datetime` range of the filter
#'   * `character` and `factor`: `selected` should be a vector of any length
#'   defining initial values selected to filter.
#'   \cr
#'   `MultiAssayExperiment` `filter` should be specified in slightly different
#'   way. Since [MultiAssayExperiment::MultiAssayExperiment()] contains
#'   patient data ([SummarizedExperiment::colData()]) with list of experiments
#'   ([MultiAssayExperiment::ExperimentList()]), `filter` list should be named
#'   in the following name.
#'   \cr
#'
#'   ```
#'   list(
#'     <MAE dataname> = list(
#'       subjects = list(<column in colData> = ..., <column in colData> = ...),
#'       <experiment name> = list(
#'         subset = list(<column in rowData of experiment> = ...,
#'                       <column in rowData of experiment> = ...),
#'         select = list(<column in colData of experiment> = ...,
#'                       <column in colData of experiment> = ...)
#'       )
#'     )
#'   )
#'   ```
#'   `filter` is ignored if the app is restored from a bookmarked state.
#'
#' @return
#' - set, remove and clear returns `NULL`
#' - get returns named `list` of the same structure as described in `filter` argument.
#'
#' @examples
#' utils::data(miniACC, package = "MultiAssayExperiment")
#'
#' datasets <- init_filtered_data(
#'   x = list(
#'     iris = list(dataset = iris),
#'     mae = list(dataset = miniACC)
#'   )
#' )
#' fs <- list(
#'   iris = list(
#'     Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE),
#'     Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE)
#'   ),
#'   mae = list(
#'     subjects = list(
#'       years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE),
#'       vital_status = list(selected = "1", keep_na = FALSE),
#'       gender = list(selected = "female", keep_na = TRUE)
#'     ),
#'     RPPAArray = list(
#'       subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE))
#'     )
#'   )
#' )
#'
#' # set initial filter state
#' isolate(set_filter_state(datasets, filter = fs))
#'
#' # get filter state
#' get_filter_state(datasets)
#'
#' # modify filter state
#' isolate(
#'   set_filter_state(
#'     datasets,
#'     filter = list(iris = list(Species = list(selected = "setosa", keep_na = TRUE)))
#'   )
#' )
#'
#' # remove specific filters
#' isolate(
#'   remove_filter_state(datasets,
#'     filter = list(
#'       iris = "Species",
#'       mae = list(
#'         subjects = c("years_to_birth", "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_list(filter, min.len = 0, null.ok = TRUE)
  if (length(filter) > 0) {
    datasets$set_filter_state(filter)
  }
  invisible(NULL)
}

#' @rdname filter_state_api
#' @export
get_filter_state <- function(datasets) {
  checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
  if (shiny::isRunning()) {
    datasets$get_filter_state()
  } else {
    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_list(filter, min.len = 0, null.ok = TRUE)
  if (length(filter) > 0) {
    datasets$remove_filter_state(filter)
  }
  invisible(NULL)
}

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

1		#' @title `FilterStates` subclass for MultiAssayExperiments
2		#' @description Handles filter states in a `MultiAssayExperiment`
3		#' @keywords internal
4		#'
5		#'
6		MAEFilterStates <- R6::R6Class( # nolint
7		classname = "MAEFilterStates",
8		inherit = FilterStates,
9
10		# public methods ----
11		public = list(
12		#' @description Initializes `MAEFilterStates` object
13		#'
14		#' Initialize `MAEFilterStates` object
15		#'
16		#' @param dataname (`character(1)`)\cr
17		#' name of the data used in the expression
18		#' specified to the function argument attached to this `FilterStates`.
19		#'
20		#' @param datalabel (`character(0)` or `character(1)`)\cr
21		#' text label value.
22		#'
23		#' @param varlabels (`character`)\cr
24		#' labels of the variables used in this object
25		#'
26		#' @param keys (`character`)\cr
27		#' key columns names
28		initialize = function(dataname, datalabel, varlabels, keys) {
29	53x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
30	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
31		}
32	53x	super$initialize(dataname, datalabel)
33	53x	private$keys <- keys
34	53x	private$varlabels <- varlabels
35	53x	private$state_list <- list(
36	53x	y = reactiveVal()
37		)
38	53x	return(invisible(self))
39		},
40
41		#' @description
42		#' Returns the formatted string representing this `MAEFilterStates` object.
43		#'
44		#' @param indent (`numeric(1)`) the number of spaces before each line of the representation
45		#' @return `character(1)` the formatted string
46		format = function(indent = 0) {
47	7x	checkmate::assert_number(indent, finite = TRUE, lower = 0)
48
49	6x	if (length(self$state_list_get(1L)) > 0) {
50	5x	formatted_states <- sprintf("%sSubject filters:", format("", width = indent))
51	5x	for (state in self$state_list_get(1L)) {
52	14x	formatted_states <- c(formatted_states, state$format(indent = indent + 2))
53		}
54	5x	paste(formatted_states, collapse = "\n")
55		}
56		},
57
58		#' @description
59		#' Returns function name used to create filter call.
60		#' For `MAEFilterStates` `MultiAssayExperiment::subsetByColData` is used.
61		#' @return `character(1)`
62		get_fun = function() {
63	11x	"MultiAssayExperiment::subsetByColData"
64		},
65
66		#' @description
67		#' Server module
68		#' @param id (`character(1)`)\cr
69		#' an ID string that corresponds with the ID used to call the module's UI function.
70		#' @return `moduleServer` function which returns `NULL`
71		server = function(id) {
72	1x	moduleServer(
73	1x	id = id,
74	1x	function(input, output, session) {
75	1x	previous_state <- reactiveVal(isolate(self$state_list_get("y")))
76	1x	added_state_name <- reactiveVal(character(0))
77	1x	removed_state_name <- reactiveVal(character(0))
78
79	1x	observeEvent(self$state_list_get("y"), {
80	2x	added_state_name(setdiff(names(self$state_list_get("y")), names(previous_state())))
81	2x	removed_state_name(setdiff(names(previous_state()), names(self$state_list_get("y"))))
82
83	2x	previous_state(self$state_list_get("y"))
84		})
85
86	1x	observeEvent(added_state_name(), ignoreNULL = TRUE, {
87	1x	fstates <- self$state_list_get("y")
88	1x	html_ids <- private$map_vars_to_html_ids(names(fstates))
89	1x	for (fname in added_state_name()) {
90	!	private$insert_filter_state_ui(
91	!	id = html_ids[fname],
92	!	filter_state = fstates[[fname]],
93	!	state_list_index = "y",
94	!	state_id = fname
95		)
96		}
97	1x	added_state_name(character(0))
98		})
99
100	1x	observeEvent(removed_state_name(), {
101	3x	req(removed_state_name())
102	1x	for (fname in removed_state_name()) {
103	3x	private$remove_filter_state_ui("y", fname, .input = input)
104		}
105	1x	removed_state_name(character(0))
106		})
107	1x	NULL
108		}
109		)
110		},
111
112		#' @description
113		#' Returns active `FilterState` objects.
114		#'
115		#' Gets all active filters from this dataset in form of the nested list.
116		#' The output list can be used as input to `self$set_filter_state`.
117		#'
118		#' @return `list` with elements number equal number of `FilterStates`.
119		get_filter_state = function() {
120	11x	lapply(self$state_list_get(state_list_index = "y"), function(x) x$get_state())
121		},
122
123		#' @description
124		#' Set filter state
125		#'
126		#' @param data (`MultiAssayExperiment`)\cr
127		#' data which are supposed to be filtered.
128		#' @param state (`named list`)\cr
129		#' should contain values which are initial selection in the `FilterState`.
130		#' Names of the `list` element should correspond to the name of the
131		#' column in `colData(data)`.
132		#' @param ... ignored.
133		#' @return `NULL`
134		set_filter_state = function(data, state, ...) {
135	17x	checkmate::assert_class(data, "MultiAssayExperiment")
136	17x	checkmate::assert(
137	17x	checkmate::check_subset(names(state), names(SummarizedExperiment::colData(data))),
138	17x	checkmate::check_class(state, "default_filter"),
139	17x	combine = "or"
140		)
141	15x	logger::log_trace("MAEFilterState$set_filter_state initializing, dataname: { private$dataname }")
142	15x	filter_states <- self$state_list_get("y")
143	15x	for (varname in names(state)) {
144	42x	value <- resolve_state(state[[varname]])
145	42x	if (varname %in% names(filter_states)) {
146	1x	fstate <- filter_states[[varname]]
147	1x	fstate$set_state(value)
148		} else {
149	41x	fstate <- init_filter_state(
150	41x	SummarizedExperiment::colData(data)[[varname]],
151	41x	varname = varname,
152	41x	varlabel = private$get_varlabels(varname),
153	41x	dataname = private$dataname,
154	41x	extract_type = "list"
155		)
156	41x	fstate$set_state(value)
157	41x	fstate$set_na_rm(TRUE)
158	41x	self$state_list_push(
159	41x	x = fstate,
160	41x	state_list_index = "y",
161	41x	state_id = varname
162		)
163		}
164		}
165	15x	logger::log_trace("MAEFilterState$set_filter_state initialized, dataname: { private$dataname }")
166	15x	NULL
167		},
168
169		#' @description
170		#' Removes a variable from the `state_list` and its corresponding UI element.
171		#'
172		#' @param state_id (`character(1)`)\cr name of `state_list` element.
173		#'
174		#' @return `NULL`
175		#'
176		remove_filter_state = function(state_id) {
177	3x	logger::log_trace(
178	3x	sprintf(
179	3x	"%s$remove_filter_state for %s called, dataname: %s",
180	3x	class(self)[1],
181	3x	state_id,
182	3x	private$dataname
183		)
184		)
185
186	3x	if (!state_id %in% names(self$state_list_get("y"))) {
187	1x	warning(paste(
188	1x	"Variable:", state_id,
189	1x	"is not present in the actual active filters of dataset: { private$dataname }",
190	1x	"therefore no changes are applied."
191		))
192	1x	logger::log_warn(
193	1x	paste(
194	1x	"Variable:", state_id, "is not present in the actual active filters of dataset:",
195	1x	"{ private$dataname } therefore no changes are applied."
196		)
197		)
198		} else {
199	2x	self$state_list_remove(state_list_index = "y", state_id = state_id)
200	2x	logger::log_trace(
201	2x	sprintf(
202	2x	"%s$remove_filter_state for variable %s done, dataname: %s",
203	2x	class(self)[1],
204	2x	state_id,
205	2x	private$dataname
206		)
207		)
208		}
209		},
210
211		# shiny modules ----
212
213		#' @description
214		#' Shiny UI module to add filter variable
215		#' @param id (`character(1)`)\cr
216		#' id of shiny module
217		#' @param data (`MultiAssayExperiment`)\cr
218		#' object containing `colData` which columns are used to be used
219		#' to choose filter variables
220		#'
221		#' @return `shiny.tag`
222		#'
223		ui_add_filter_state = function(id, data) {
224	2x	checkmate::assert_string(id)
225	2x	stopifnot(is(data, "MultiAssayExperiment"))
226
227	2x	ns <- NS(id)
228
229	2x	if (ncol(SummarizedExperiment::colData(data)) == 0) {
230	1x	div("no sample variables available")
231	1x	} else if (nrow(SummarizedExperiment::colData(data)) == 0) {
232	1x	div("no samples available")
233		} else {
234	!	teal.widgets::optionalSelectInput(
235	!	ns("var_to_add"),
236	!	choices = NULL,
237	!	options = shinyWidgets::pickerOptions(
238	!	liveSearch = TRUE,
239	!	noneSelectedText = "Select subject variable"
240		)
241		)
242		}
243		},
244
245		#' @description
246		#' Shiny server module to add filter variable.
247		#'
248		#' Module controls available choices to select as a filter variable.
249		#' Selected filter variable is being removed from available choices.
250		#' Removed filter variable gets back to available choices.
251		#'
252		#' @param id (`character(1)`)\cr
253		#' an ID string that corresponds with the ID used to call the module's UI function.
254		#' @param data (`MultiAssayExperiment`)\cr
255		#' object containing `colData` which columns are used to choose filter variables in
256		#' [teal.widgets::optionalSelectInput()].
257		#' @param ... ignored
258		#'
259		#' @return `moduleServer` function which returns `NULL`
260		#'
261		srv_add_filter_state = function(id, data, ...) {
262	!	stopifnot(is(data, "MultiAssayExperiment"))
263	!	check_ellipsis(..., stop = FALSE)
264	!	moduleServer(
265	!	id = id,
266	!	function(input, output, session) {
267	!	logger::log_trace(
268	!	"MAEFilterState$srv_add_filter_state initializing, dataname: { private$dataname }"
269		)
270	!	shiny::setBookmarkExclude("var_to_add")
271	!	active_filter_vars <- reactive({
272	!	vapply(
273	!	X = self$state_list_get(state_list_index = "y"),
274	!	FUN.VALUE = character(1),
275	!	FUN = function(x) x$get_varname()
276		)
277		})
278
279		# available choices to display
280	!	avail_column_choices <- reactive({
281	!	choices <- setdiff(
282	!	get_supported_filter_varnames(data = SummarizedExperiment::colData(data)),
283	!	active_filter_vars()
284		)
285	!	data_choices_labeled(
286	!	data = SummarizedExperiment::colData(data),
287	!	choices = choices,
288	!	varlabels = private$get_varlabels(choices),
289	!	keys = private$keys
290		)
291		})
292	!	observeEvent(
293	!	avail_column_choices(),
294	!	ignoreNULL = TRUE,
295	!	handlerExpr = {
296	!	logger::log_trace(paste(
297	!	"MAEFilterStates$srv_add_filter_state@1 updating available column choices,",
298	!	"dataname: { private$dataname }"
299		))
300	!	if (is.null(avail_column_choices())) {
301	!	shinyjs::hide("var_to_add")
302		} else {
303	!	shinyjs::show("var_to_add")
304		}
305	!	teal.widgets::updateOptionalSelectInput(
306	!	session,
307	!	"var_to_add",
308	!	choices = avail_column_choices()
309		)
310	!	logger::log_trace(paste(
311	!	"MAEFilterStates$srv_add_filter_state@1 updated available column choices,",
312	!	"dataname: { private$dataname }"
313		))
314		}
315		)
316
317	!	observeEvent(
318	!	eventExpr = input$var_to_add,
319	!	handlerExpr = {
320	!	logger::log_trace(
321	!	sprintf(
322	!	"MAEFilterStates$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s",
323	!	deparse1(input$var_to_add),
324	!	private$dataname
325		)
326		)
327	!	fstate <- init_filter_state(
328	!	SummarizedExperiment::colData(data)[[input$var_to_add]],
329	!	varname = input$var_to_add,
330	!	varlabel = private$get_varlabels(input$var_to_add),
331	!	dataname = private$dataname,
332	!	extract_type = "list"
333		)
334	!	fstate$set_na_rm(TRUE)
335
336	!	self$state_list_push(
337	!	x = fstate,
338	!	state_list_index = "y",
339	!	state_id = input$var_to_add
340		)
341	!	logger::log_trace(
342	!	sprintf(
343	!	"MAEFilterStates$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s",
344	!	deparse1(input$var_to_add),
345	!	private$dataname
346		)
347		)
348		}
349		)
350
351	!	logger::log_trace(
352	!	"MAEFilterState$srv_add_filter_state initialized, dataname: { private$dataname }"
353		)
354	!	NULL
355		}
356		)
357		}
358		),
359
360		# private members ----
361		private = list(
362		varlabels = character(0),
363		keys = character(0),
364		#' description
365		#' Get label of specific variable. In case when variable label is missing
366		#' name of the variable is returned.
367		#' parameter variable (`character`)\cr
368		#' name of the variable for which label should be returned
369		#' return `character`
370		get_varlabels = function(variables = character(0)) {
371	41x	checkmate::assert_character(variables)
372	41x	if (identical(variables, character(0))) {
373	!	private$varlabels
374		} else {
375	41x	varlabels <- private$varlabels[variables]
376	41x	missing_labels <- is.na(varlabels) \| varlabels == ""
377	41x	varlabels[missing_labels] <- variables[missing_labels]
378	41x	varlabels
379		}
380		}
381		)
382		)

1		#' @title `FilterStates` subclass for SummarizedExperiments
2		#' @description Handles filter states in a `SummaryExperiment`
3		#' @keywords internal
4		#'
5		#'
6		SEFilterStates <- R6::R6Class( # nolint
7		classname = "SEFilterStates",
8		inherit = FilterStates,
9
10		# public methods ----
11		public = list(
12		#' @description Initialize `SEFilterStates` object
13		#'
14		#' Initialize `SEFilterStates` object
15		#'
16		#' @param dataname (`character(1)`)\cr
17		#' name of the data used in the expression
18		#' specified to the function argument attached to this `FilterStates`.
19		#'
20		#' @param datalabel (`character(0)` or `character(1)`)\cr
21		#' text label value.
22		initialize = function(dataname, datalabel) {
23	146x	if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
24	!	stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
25		}
26	146x	super$initialize(dataname, datalabel)
27	146x	private$state_list <- list(
28	146x	subset = reactiveVal(),
29	146x	select = reactiveVal()
30		)
31		},
32
33		#' @description
34		#' Returns the formatted string representing this `MAEFilterStates` object.
35		#'
36		#' @param indent (`numeric(1)`) the number of spaces before each line of the representation
37		#' @return `character(1)` the formatted string
38		format = function(indent = 0) {
39	19x	checkmate::assert_number(indent, finite = TRUE, lower = 0)
40
41	18x	whitespace_indent <- format("", width = indent)
42	18x	formatted_states <- c()
43	18x	if (!is.null(self$state_list_get(state_list_index = "subset"))) {
44	5x	formatted_states <- c(formatted_states, paste0(whitespace_indent, " Subsetting:"))
45	5x	for (state in self$state_list_get(state_list_index = "subset")) {
46	5x	formatted_states <- c(formatted_states, state$format(indent = indent + 4))
47		}
48		}
49
50	18x	if (!is.null(self$state_list_get(state_list_index = "select"))) {
51	1x	formatted_states <- c(formatted_states, paste0(whitespace_indent, " Selecting:"))
52	1x	for (state in self$state_list_get(state_list_index = "select")) {
53	1x	formatted_states <- c(formatted_states, state$format(indent = indent + 4))
54		}
55		}
56
57	18x	if (length(formatted_states) > 0) {
58	5x	formatted_states <- c(paste0(whitespace_indent, "Assay ", self$get_datalabel(), " filters:"), formatted_states)
59	5x	paste(formatted_states, collapse = "\n")
60		}
61		},
62
63		#' @description
64		#' Server module
65		#' @param id (`character(1)`)\cr
66		#' an ID string that corresponds with the ID used to call the module's UI function.
67		#' @return `moduleServer` function which returns `NULL`
68		server = function(id) {
69	4x	moduleServer(
70	4x	id = id,
71	4x	function(input, output, session) {
72	4x	previous_state_subset <- reactiveVal(isolate(self$state_list_get("subset")))
73	4x	added_state_name_subset <- reactiveVal(character(0))
74	4x	removed_state_name_subset <- reactiveVal(character(0))
75
76	4x	observeEvent(self$state_list_get("subset"), {
77	5x	added_state_name_subset(
78	5x	setdiff(names(self$state_list_get("subset")), names(previous_state_subset()))
79		)
80	5x	removed_state_name_subset(
81	5x	setdiff(names(previous_state_subset()), names(self$state_list_get("subset")))
82		)
83	5x	previous_state_subset(self$state_list_get("subset"))
84		})
85
86	4x	observeEvent(added_state_name_subset(), ignoreNULL = TRUE, {
87	4x	fstates <- self$state_list_get("subset")
88	4x	html_ids <- private$map_vars_to_html_ids(keys = names(fstates), prefix = "rowData")
89	4x	for (fname in added_state_name_subset()) {
90	!	private$insert_filter_state_ui(
91	!	id = html_ids[fname],
92	!	filter_state = fstates[[fname]],
93	!	state_list_index = "subset",
94	!	state_id = fname
95		)
96		}
97	4x	added_state_name_subset(character(0))
98		})
99
100	4x	observeEvent(removed_state_name_subset(), {
101	6x	req(removed_state_name_subset())
102	1x	for (fname in removed_state_name_subset()) {
103	1x	private$remove_filter_state_ui("subset", fname, .input = input)
104		}
105	1x	removed_state_name_subset(character(0))
106		})
107
108		# select
109	4x	previous_state_select <- reactiveVal(isolate(self$state_list_get("select")))
110	4x	added_state_name_select <- reactiveVal(character(0))
111	4x	removed_state_name_select <- reactiveVal(character(0))
112
113	4x	observeEvent(self$state_list_get("select"), {
114		# find what has been added or removed
115	4x	added_state_name_select(
116	4x	setdiff(names(self$state_list_get("select")), names(previous_state_select()))
117		)
118	4x	removed_state_name_select(
119	4x	setdiff(names(previous_state_select()), names(self$state_list_get("select")))
120		)
121	4x	previous_state_select(self$state_list_get("select"))
122		})
123
124	4x	observeEvent(added_state_name_select(), ignoreNULL = TRUE, {
125	4x	fstates <- self$state_list_get("select")
126	4x	html_ids <- private$map_vars_to_html_ids(keys = names(fstates), prefix = "colData")
127	4x	for (fname in added_state_name_select()) {
128	!	private$insert_filter_state_ui(
129	!	id = html_ids[fname],
130	!	filter_state = fstates[[fname]],
131	!	state_list_index = "select",
132	!	state_id = fname
133		)
134		}
135	4x	added_state_name_select(character(0))
136		})
137
138	4x	observeEvent(removed_state_name_select(), {
139	4x	req(removed_state_name_select())
140	!	for (fname in removed_state_name_select()) {
141	!	private$remove_filter_state_ui("select", fname, .input = input)
142		}
143	!	removed_state_name_select(character(0))
144		})
145	4x	NULL
146		}
147		)
148		},
149
150		#' @description
151		#' Gets the reactive values from the active `FilterState` objects.
152		#'
153		#' Gets all active filters from this dataset in form of the nested list.
154		#' The output list is a compatible input to `self$set_filter_state`.
155		#'
156		#' @return `list` containing one or two lists depending on the number of
157		#' `state_list` object (I.e. if `rowData` and `colData` exist). Each
158		#' `list` contains elements number equal to number of active filter variables.
159		get_filter_state = function() {
160	40x	states <- sapply(
161	40x	X = names(private$state_list),
162	40x	simplify = FALSE,
163	40x	function(x) {
164	80x	lapply(self$state_list_get(state_list_index = x), function(xx) xx$get_state())
165		}
166		)
167	40x	Filter(function(x) length(x) > 0, states)
168		},
169
170		#' @description
171		#' Set filter state
172		#'
173		#' @param data (`SummarizedExperiment`)\cr
174		#' data which are supposed to be filtered.
175		#' @param state (`named list`)\cr
176		#' this list should contain `subset` and `select` element where
177		#' each should be a named list containing values as a selection in the `FilterState`.
178		#' Names of each the `list` element in `subset` and `select` should correspond to
179		#' the name of the column in `rowData(data)` and `colData(data)`.
180		#' @param ... ignored.
181		#' @return `NULL`
182		set_filter_state = function(data, state, ...) {
183	30x	checkmate::assert_class(data, "SummarizedExperiment")
184	27x	checkmate::assert_class(state, "list")
185
186	26x	checkmate::assert(
187	26x	checkmate::check_subset(names(state), c("subset", "select")),
188	26x	checkmate::check_class(state, "default_filter"),
189	26x	combine = "or"
190		)
191	25x	checkmate::assert(
192	25x	checkmate::test_null(state$subset),
193	25x	checkmate::assert(
194	25x	checkmate::check_class(state$subset, "list"),
195	25x	checkmate::check_subset(names(state$subset), names(SummarizedExperiment::rowData(data))),
196	25x	combine = "and"
197		),
198	25x	combine = "or"
199		)
200	25x	checkmate::assert(
201	25x	checkmate::test_null(state$select),
202	25x	checkmate::assert(
203	25x	checkmate::check_class(state$select, "list"),
204	25x	checkmate::check_subset(names(state$select), names(SummarizedExperiment::colData(data))),
205	25x	combine = "and"
206		),
207	25x	combine = "or"
208		)
209
210	25x	filter_states <- self$state_list_get("subset")
211	25x	for (varname in names(state$subset)) {
212	20x	value <- resolve_state(state$subset[[varname]])
213	20x	if (varname %in% names(filter_states)) {
214	2x	fstate <- filter_states[[varname]]
215	2x	fstate$set_state(value)
216		} else {
217	18x	fstate <- init_filter_state(
218	18x	SummarizedExperiment::rowData(data)[[varname]],
219	18x	varname = varname,
220	18x	dataname = private$dataname
221		)
222	18x	fstate$set_state(value)
223	18x	self$state_list_push(
224	18x	x = fstate,
225	18x	state_list_index = "subset",
226	18x	state_id = varname
227		)
228		}
229		}
230
231	25x	filter_states <- self$state_list_get("select")
232	25x	for (varname in names(state$select)) {
233	9x	value <- resolve_state(state$select[[varname]])
234	9x	if (varname %in% names(filter_states)) {
235	1x	fstate <- filter_states[[varname]]
236	1x	fstate$set_state(value)
237		} else {
238	8x	fstate <- init_filter_state(
239	8x	SummarizedExperiment::colData(data)[[varname]],
240	8x	varname = varname,
241	8x	dataname = private$dataname
242		)
243	8x	fstate$set_state(value)
244	8x	self$state_list_push(
245	8x	x = fstate,
246	8x	state_list_index = "select",
247	8x	state_id = varname
248		)
249		}
250		}
251	25x	logger::log_trace(paste(
252	25x	"SEFilterState$set_filter_state initialized,",
253	25x	"dataname: { private$dataname }"
254		))
255	25x	NULL
256		},
257
258		#' @description Remove a variable from the `state_list` and its corresponding UI element.
259		#'
260		#' @param state_id (`character(1)`)\cr name of `state_list` element.
261		#'
262		#' @return `NULL`
263		remove_filter_state = function(state_id) {
264	4x	logger::log_trace(
265	4x	sprintf(
266	4x	"%s$remove_filter_state called, dataname: %s",
267	4x	class(self)[1],
268	4x	private$dataname
269		)
270		)
271
272	4x	checkmate::assert(
273	4x	!checkmate::test_null(names(state_id)),
274	4x	checkmate::check_subset(names(state_id), c("subset", "select")),
275	4x	combine = "and"
276		)
277	3x	for (varname in state_id$subset) {
278	3x	if (!all(unlist(state_id$subset) %in% names(self$state_list_get("subset")))) {
279	1x	warning(paste(
280	1x	"Variable:", state_id, "is not present in the actual active subset filters of dataset:",
281	1x	"{ private$dataname } therefore no changes are applied."
282		))
283	1x	logger::log_warn(
284	1x	paste(
285	1x	"Variable:", state_id, "is not present in the actual active subset filters of dataset:",
286	1x	"{ private$dataname } therefore no changes are applied."
287		)
288		)
289		} else {
290	2x	self$state_list_remove(state_list_index = "subset", state_id = varname)
291	2x	logger::log_trace(
292	2x	sprintf(
293	2x	"%s$remove_filter_state for subset variable %s done, dataname: %s",
294	2x	class(self)[1],
295	2x	varname,
296	2x	private$dataname
297		)
298		)
299		}
300		}
301
302	3x	for (varname in state_id$select) {
303	1x	if (!all(unlist(state_id$select) %in% names(self$state_list_get("select")))) {
304	!	warning(paste(
305	!	"Variable:", state_id, "is not present in the actual active select filters of dataset:",
306	!	"{ private$dataname } therefore no changes are applied."
307		))
308	!	logger::log_warn(
309	!	paste(
310	!	"Variable:", state_id, "is not present in the actual active select filters of dataset:",
311	!	"{ private$dataname } therefore no changes are applied."
312		)
313		)
314		} else {
315	1x	self$state_list_remove(state_list_index = "select", state_id = varname)
316	1x	sprintf(
317	1x	"%s$remove_filter_state for select variable %s done, dataname: %s",
318	1x	class(self)[1],
319	1x	varname,
320	1x	private$dataname
321		)
322		}
323		}
324		},
325
326		# shiny modules ----
327
328		#' @description
329		#' Shiny UI module to add filter variable
330		#' @param id (`character(1)`)\cr
331		#' id of shiny module
332		#' @param data (`SummarizedExperiment`)\cr
333		#' object containing `colData` and `rowData` which columns
334		#' are used to choose filter variables. Column selection from `colData`
335		#' and `rowData` are separate shiny entities.
336		#' @return shiny.tag
337		ui_add_filter_state = function(id, data) {
338	2x	checkmate::assert_string(id)
339	2x	stopifnot(is(data, "SummarizedExperiment"))
340
341	2x	ns <- NS(id)
342
343	2x	row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
344	1x	div("no sample variables available")
345	2x	} else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
346	1x	div("no samples available")
347		} else {
348	!	teal.widgets::optionalSelectInput(
349	!	ns("row_to_add"),
350	!	choices = NULL,
351	!	options = shinyWidgets::pickerOptions(
352	!	liveSearch = TRUE,
353	!	noneSelectedText = "Select gene variable"
354		)
355		)
356		}
357
358	2x	col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
359	1x	div("no sample variables available")
360	2x	} else if (nrow(SummarizedExperiment::colData(data)) == 0) {
361	1x	div("no samples available")
362		} else {
363	!	teal.widgets::optionalSelectInput(
364	!	ns("col_to_add"),
365	!	choices = NULL,
366	!	options = shinyWidgets::pickerOptions(
367	!	liveSearch = TRUE,
368	!	noneSelectedText = "Select sample variable"
369		)
370		)
371		}
372
373	2x	div(
374	2x	row_input,
375	2x	col_input
376		)
377		},
378
379		#' @description
380		#' Shiny server module to add filter variable
381		#'
382		#' Module controls available choices to select as a filter variable.
383		#' Selected filter variable is being removed from available choices.
384		#' Removed filter variable gets back to available choices.
385		#' This module unlike other `FilterStates` classes manages two
386		#' sets of filter variables - one for `colData` and another for
387		#' `rowData`.
388		#'
389		#' @param id (`character(1)`)\cr
390		#' an ID string that corresponds with the ID used to call the module's UI function.
391		#' @param data (`SummarizedExperiment`)\cr
392		#' object containing `colData` and `rowData` which columns
393		#' are used to choose filter variables. Column selection from `colData`
394		#' and `rowData` are separate shiny entities.
395		#' @param ... ignored
396		#' @return `moduleServer` function which returns `NULL`
397		srv_add_filter_state = function(id, data, ...) {
398	!	stopifnot(is(data, "SummarizedExperiment"))
399	!	check_ellipsis(..., stop = FALSE)
400	!	moduleServer(
401	!	id = id,
402	!	function(input, output, session) {
403	!	logger::log_trace(
404	!	"SEFilterState$srv_add_filter_state initializing, dataname: { private$dataname }"
405		)
406	!	shiny::setBookmarkExclude(c("row_to_add", "col_to_add"))
407	!	active_filter_col_vars <- reactive({
408	!	vapply(
409	!	X = self$state_list_get(state_list_index = "select"),
410	!	FUN.VALUE = character(1),
411	!	FUN = function(x) x$get_varname()
412		)
413		})
414	!	active_filter_row_vars <- reactive({
415	!	vapply(
416	!	X = self$state_list_get(state_list_index = "subset"),
417	!	FUN.VALUE = character(1),
418	!	FUN = function(x) x$get_varname()
419		)
420		})
421
422	!	row_data <- SummarizedExperiment::rowData(data)
423	!	col_data <- SummarizedExperiment::colData(data)
424
425		# available choices to display
426	!	avail_row_data_choices <- reactive({
427	!	choices <- setdiff(
428	!	get_supported_filter_varnames(data = row_data),
429	!	active_filter_row_vars()
430		)
431
432	!	data_choices_labeled(
433	!	data = row_data,
434	!	choices = choices,
435	!	varlabels = character(0),
436	!	keys = NULL
437		)
438		})
439	!	avail_col_data_choices <- reactive({
440	!	choices <- setdiff(
441	!	get_supported_filter_varnames(data = col_data),
442	!	active_filter_col_vars()
443		)
444
445	!	data_choices_labeled(
446	!	data = col_data,
447	!	choices = choices,
448	!	varlabels = character(0),
449	!	keys = NULL
450		)
451		})
452
453
454	!	observeEvent(
455	!	avail_row_data_choices(),
456	!	ignoreNULL = TRUE,
457	!	handlerExpr = {
458	!	logger::log_trace(paste(
459	!	"SEFilterStates$srv_add_filter_state@1 updating available row data choices,",
460	!	"dataname: { private$dataname }"
461		))
462	!	if (is.null(avail_row_data_choices())) {
463	!	shinyjs::hide("row_to_add")
464		} else {
465	!	shinyjs::show("row_to_add")
466		}
467	!	teal.widgets::updateOptionalSelectInput(
468	!	session,
469	!	"row_to_add",
470	!	choices = avail_row_data_choices()
471		)
472	!	logger::log_trace(paste(
473	!	"SEFilterStates$srv_add_filter_state@1 updated available row data choices,",
474	!	"dataname: { private$dataname }"
475		))
476		}
477		)
478
479	!	observeEvent(
480	!	avail_col_data_choices(),
481	!	ignoreNULL = TRUE,
482	!	handlerExpr = {
483	!	logger::log_trace(paste(
484	!	"SEFilterStates$srv_add_filter_state@2 updating available col data choices,",
485	!	"dataname: { private$dataname }"
486		))
487	!	if (is.null(avail_col_data_choices())) {
488	!	shinyjs::hide("col_to_add")
489		} else {
490	!	shinyjs::show("col_to_add")
491		}
492	!	teal.widgets::updateOptionalSelectInput(
493	!	session,
494	!	"col_to_add",
495	!	choices = avail_col_data_choices()
496		)
497	!	logger::log_trace(paste(
498	!	"SEFilterStates$srv_add_filter_state@2 updated available col data choices,",
499	!	"dataname: { private$dataname }"
500		))
501		}
502		)
503
504	!	observeEvent(
505	!	eventExpr = input$col_to_add,
506	!	handlerExpr = {
507	!	logger::log_trace(
508	!	sprintf(
509	!	"SEFilterStates$srv_add_filter_state@3 adding FilterState of column %s to col data, dataname: %s",
510	!	deparse1(input$col_to_add),
511	!	private$dataname
512		)
513		)
514	!	self$state_list_push(
515	!	x = init_filter_state(
516	!	SummarizedExperiment::colData(data)[[input$col_to_add]],
517	!	varname = input$col_to_add,
518	!	dataname = private$dataname
519		),
520	!	state_list_index = "select",
521	!	state_id = input$col_to_add
522		)
523	!	logger::log_trace(
524	!	sprintf(
525	!	"SEFilterStates$srv_add_filter_state@3 added FilterState of column %s to col data, dataname: %s",
526	!	deparse1(input$col_to_add),
527	!	private$dataname
528		)
529		)
530		}
531		)
532
533	!	observeEvent(
534	!	eventExpr = input$row_to_add,
535	!	handlerExpr = {
536	!	logger::log_trace(
537	!	sprintf(
538	!	"SEFilterStates$srv_add_filter_state@4 adding FilterState of variable %s to row data, dataname: %s",
539	!	deparse1(input$row_to_add),
540	!	private$dataname
541		)
542		)
543	!	self$state_list_push(
544	!	x = init_filter_state(
545	!	SummarizedExperiment::rowData(data)[[input$row_to_add]],
546	!	varname = input$row_to_add,
547	!	dataname = private$dataname
548		),
549	!	state_list_index = "subset",
550	!	state_id = input$row_to_add
551		)
552	!	logger::log_trace(
553	!	sprintf(
554	!	"SEFilterStates$srv_add_filter_state@4 added FilterState of variable %s to row data, dataname: %s",
555	!	deparse1(input$row_to_add),
556	!	private$dataname
557		)
558		)
559		}
560		)
561
562	!	logger::log_trace(
563	!	"SEFilterState$srv_add_filter_state initialized, dataname: { private$dataname }"
564		)
565	!	NULL
566		}
567		)
568		}
569		)
570		)

1		#' Initializes `FilterState`
2		#'
3		#' Initializes `FilterState` depending on a variable class.\cr
4		#' @param x (`vector`)\cr
5		#' values of the variable used in filter
6		#'
7		#' @param varname (`character(1)`)\cr
8		#' name of the variable.
9		#'
10		#' @param varlabel (`character(0)`, `character(1)` or `NULL`)\cr
11		#' label of the variable (optional).
12		#'
13		#' @param dataname (`character(1)`)\cr
14		#' optional name of dataset where `x` is taken from. Must be specified
15		#' if `extract_type` argument is not empty.
16		#'
17		#' @param extract_type (`character(0)`, `character(1)`)\cr
18		#' whether condition calls should be prefixed by dataname. Possible values:
19		#' \itemize{
20		#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
21		#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
22		#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
23		#' }
24		#' @keywords internal
25		#'
26		#' @examples
27		#' filter_state <- teal.slice:::RangeFilterState$new(
28		#' c(1:10, NA, Inf),
29		#' varname = "x",
30		#' varlabel = "Pretty name",
31		#' dataname = "dataname",
32		#' extract_type = "matrix"
33		#' )
34		#'
35		#' filter_state$get_varname()
36		#' filter_state$get_varlabel()
37		#' isolate(filter_state$get_call())
38		#' \dontrun{
39		#' shinyApp(
40		#' ui = fluidPage(
41		#' isolate(filter_state$ui(id = "app")),
42		#' verbatimTextOutput("call")
43		#' ),
44		#' server = function(input, output, session) {
45		#' filter_state$server("app")
46		#'
47		#' output$call <- renderText(
48		#' deparse1(filter_state$get_call(), collapse = "\n")
49		#' )
50		#' }
51		#' )
52		#' }
53		#' @return `FilterState` object
54		init_filter_state <- function(x,
55		varname,
56		varlabel = attr(x, "label"),
57		dataname = NULL,
58		extract_type = character(0)) {
59	168x	checkmate::assert_string(varname)
60	167x	checkmate::assert_character(varlabel, max.len = 1L, any.missing = FALSE, null.ok = TRUE)
61	167x	checkmate::assert_string(dataname, null.ok = TRUE)
62	167x	checkmate::assert_character(extract_type, max.len = 1L, any.missing = FALSE)
63	167x	if (length(extract_type) == 1) {
64	47x	checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
65		}
66	167x	if (length(extract_type) == 1 && is.null(dataname)) {
67	1x	stop("if extract_type is specified, dataname must also be specified")
68		}
69
70	45x	if (is.null(varlabel)) varlabel <- character(0L)
71
72	166x	if (all(is.na(x))) {
73	1x	return(
74	1x	EmptyFilterState$new(
75	1x	x = x,
76	1x	varname = varname,
77	1x	varlabel = varlabel,
78	1x	dataname = dataname,
79	1x	extract_type = extract_type
80		)
81		)
82		}
83	165x	UseMethod("init_filter_state")
84		}
85
86		#' @keywords internal
87		#' @export
88		init_filter_state.default <- function(x,
89		varname,
90		varlabel = attr(x, "label"),
91		dataname = NULL,
92		extract_type = character(0)) {
93	1x	if (is.null(varlabel)) varlabel <- character(0)
94	1x	FilterState$new(
95	1x	x = x,
96	1x	varname = varname,
97	1x	varlabel = varlabel,
98	1x	dataname = dataname,
99	1x	extract_type = extract_type
100		)
101		}
102
103		#' @keywords internal
104		#' @export
105		init_filter_state.logical <- function(x,
106		varname,
107		varlabel = attr(x, "label"),
108		dataname = NULL,
109		extract_type = character(0)) {
110	1x	if (is.null(varlabel)) varlabel <- character(0)
111	1x	LogicalFilterState$new(
112	1x	x = x,
113	1x	varname = varname,
114	1x	varlabel = varlabel,
115	1x	dataname = dataname,
116	1x	extract_type = extract_type
117		)
118		}
119
120		#' @keywords internal
121		#' @export
122		init_filter_state.numeric <- function(x,
123		varname,
124		varlabel = attr(x, "label"),
125		dataname = NULL,
126		extract_type = character(0)) {
127	9x	if (is.null(varlabel)) varlabel <- character(0)
128	89x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
129	31x	ChoicesFilterState$new(
130	31x	x = x,
131	31x	varname = varname,
132	31x	varlabel = varlabel,
133	31x	dataname = dataname,
134	31x	extract_type = extract_type
135		)
136		} else {
137	58x	RangeFilterState$new(
138	58x	x = x,
139	58x	varname = varname,
140	58x	varlabel = varlabel,
141	58x	dataname = dataname,
142	58x	extract_type = extract_type
143		)
144		}
145		}
146
147		#' @keywords internal
148		#' @export
149		init_filter_state.factor <- function(x,
150		varname,
151		varlabel = attr(x, "label"),
152		dataname = NULL,
153		extract_type = character(0)) {
154	!	if (is.null(varlabel)) varlabel <- character(0)
155	26x	ChoicesFilterState$new(
156	26x	x = x,
157	26x	varname = varname,
158	26x	varlabel = varlabel,
159	26x	dataname = dataname,
160	26x	extract_type = extract_type
161		)
162		}
163
164		#' @keywords internal
165		#' @export
166		init_filter_state.character <- function(x,
167		varname,
168		varlabel = attr(x, "label"),
169		dataname = NULL,
170		extract_type = character(0)) {
171	27x	if (is.null(varlabel)) varlabel <- character(0)
172	42x	ChoicesFilterState$new(
173	42x	x = x,
174	42x	varname = varname,
175	42x	varlabel = varlabel,
176	42x	dataname = dataname,
177	42x	extract_type = extract_type
178		)
179		}
180
181		#' @keywords internal
182		#' @export
183		init_filter_state.Date <- function(x,
184		varname,
185		varlabel = attr(x, "label"),
186		dataname = NULL,
187		extract_type = character(0)) {
188	2x	if (is.null(varlabel)) varlabel <- character(0)
189	2x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
190	1x	ChoicesFilterState$new(
191	1x	x = x,
192	1x	varname = varname,
193	1x	varlabel = varlabel,
194	1x	dataname = dataname,
195	1x	extract_type = extract_type
196		)
197		} else {
198	1x	DateFilterState$new(
199	1x	x = x,
200	1x	varname = varname,
201	1x	varlabel = varlabel,
202	1x	dataname = dataname,
203	1x	extract_type = extract_type
204		)
205		}
206		}
207
208		#' @keywords internal
209		#' @export
210		init_filter_state.POSIXct <- function(x,
211		varname,
212		varlabel = attr(x, "label"),
213		dataname = NULL,
214		extract_type = character(0)) {
215	2x	if (is.null(varlabel)) varlabel <- character(0)
216	2x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
217	1x	ChoicesFilterState$new(
218	1x	x = x,
219	1x	varname = varname,
220	1x	varlabel = varlabel,
221	1x	dataname = dataname,
222	1x	extract_type = extract_type
223		)
224		} else {
225	1x	DatetimeFilterState$new(
226	1x	x = x,
227	1x	varname = varname,
228	1x	varlabel = varlabel,
229	1x	dataname = dataname,
230	1x	extract_type = extract_type
231		)
232		}
233		}
234
235		#' @keywords internal
236		#' @export
237		init_filter_state.POSIXlt <- function(x,
238		varname,
239		varlabel = attr(x, "label"),
240		dataname = NULL,
241		extract_type = character(0)) {
242	2x	if (is.null(varlabel)) varlabel <- character(0)
243	2x	if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
244	1x	ChoicesFilterState$new(
245	1x	x = x,
246	1x	varname = varname,
247	1x	varlabel = varlabel,
248	1x	dataname = dataname,
249	1x	extract_type = extract_type
250		)
251		} else {
252	1x	DatetimeFilterState$new(
253	1x	x = x,
254	1x	varname = varname,
255	1x	varlabel = varlabel,
256	1x	dataname = dataname,
257	1x	extract_type = extract_type
258		)
259		}
260		}
261
262		#' Check that a given range is valid
263		#'
264		#' @param subinterval (`numeric` or `date`)\cr vector of length 2 to be compared against the full range.
265		#' @param range (`numeric` or `date`)\cr vector of length 2 containing the full range to validate against.
266		#' @param pre_msg `character` message to print before error for additional context.
267		#'
268		#' @return `NULL` if `subinterval` is a valid range or error with message otherwise.
269		#' @keywords internal
270		#'
271		#' @examples
272		#' \dontrun{
273		#' check_in_range(c(3, 1), c(1, 3))
274		#' check_in_range(c(0, 3), c(1, 3))
275		#' check_in_range(
276		#' c(as.Date("2020-01-01"), as.Date("2020-01-20")),
277		#' c(as.Date("2020-01-01"), as.Date("2020-01-02"))
278		#' )
279		#' }
280		check_in_range <- function(subinterval, range, pre_msg = "") {
281	81x	epsilon <- .Machine$double.eps^0.5 # needed for floating point arithmetic; same value as in base::all.equal()
282	81x	if ((length(subinterval) != 2)) {
283	!	stop(
284	!	sprintf(
285	!	"%s range length should be 2 while it is %s",
286	!	pre_msg,
287	!	length(subinterval)
288		)
289		)
290		}
291	81x	if (subinterval[[2]] + epsilon < subinterval[[1]]) {
292	2x	stop(sprintf(
293	2x	"%s unexpected: the upper bound of the range lower than the lower bound \n %s < %s",
294	2x	pre_msg,
295	2x	subinterval[[2]],
296	2x	subinterval[[1]]
297		))
298		}
299
300	79x	if ((subinterval[[1]] + epsilon < range[[1]]) \|\| (subinterval[[2]] - epsilon > range[[2]])) {
301	!	stop(
302	!	sprintf(
303	!	"%s range (%s) not valid for full range (%s)",
304	!	pre_msg, toString(subinterval), toString(range)
305		)
306		)
307		}
308		}
309
310		#' Check that one set is a subset of another
311		#'
312		#' Raises an error message if not and says which elements are not in the allowed `choices`.
313		#'
314		#' @param subset `collection-like` should be a subset of the second argument `choices`
315		#' @param choices `collection-like` superset
316		#' @param pre_msg `character` message to print before error should there be any errors
317		#' @keywords internal
318		#'
319		#' @examples
320		#' \dontrun{
321		#' check_in_subset <- check_in_subset
322		#' check_in_subset(c("a", "b"), c("a", "b", "c"))
323		#' \dontrun{
324		#' check_in_subset(c("a", "b"), c("b", "c"), pre_msg = "Error: ")
325		#' # truncated because too long
326		#' check_in_subset("a", LETTERS, pre_msg = "Error: ")
327		#' }
328		#' }
329		check_in_subset <- function(subset, choices, pre_msg = "") {
330	333x	checkmate::assert_string(pre_msg)
331
332	333x	subset <- unique(subset)
333	333x	choices <- unique(choices)
334
335	333x	if (any(!(subset %in% choices))) {
336	3x	stop(paste0(
337	3x	pre_msg,
338	3x	"(", toString(subset[!(subset %in% choices)], width = 30), ")",
339	3x	" not in valid choices ",
340	3x	"(", toString(choices, width = 30), ")"
341	3x	), call. = FALSE)
342		}
343	330x	return(invisible(NULL))
344		}
345
346		#' Find containing limits for interval.
347		#'
348		#' Given an interval and a numeric vector,
349		#' find the smallest interval within the numeric vector that contains the interval.
350		#'
351		#' This is a helper function for `RangeFilterState` that modifies slider selection
352		#' so that the _subsetting call_ includes the value specified by the filter API call.
353		#'
354		#' Regardless of the underlying numeric data, the slider always presents 100 steps.
355		#' The ticks on the slider do not represent actual observations but rather borders between virtual bins.
356		#' Since the value selected on the slider is passed to `private$selected` and that in turn
357		#' updates the slider selection, programmatic selection of arbitrary values may inadvertently shift
358		#' the selection to the closest tick, thereby dropping the actual value set (if it exists in the data).
359		#'
360		#' This function purposely shifts the selection to the closest ticks whose values form an interval
361		#' that will contain the interval defined by the filter API call.
362		#'
363		#' @param x `numeric(2)` interval to contain
364		#' @param range `numeric(>=2)` vector of values to contain `x` in
365		#'
366		#' @return Numeric vector of length 2 that lies within `range`.
367		#'
368		#' @keywords internal
369		#'
370		#' @examples
371		#' \dontrun{
372		#' ticks <- 1:10
373		#' values1 <- c(3, 5)
374		#' contain_interval(values1, ticks)
375		#' values2 <- c(3.1, 5.7)
376		#' contain_interval(values2, ticks)
377		#' values3 <- c(0, 20)
378		#' contain_interval(values3, ticks)
379		#'}
380		contain_interval <- function(x, range) {
381	169x	checkmate::assert_numeric(x, len = 2L, any.missing = FALSE, sorted = TRUE)
382	165x	checkmate::assert_numeric(range, min.len = 2L, any.missing = FALSE, sorted = TRUE)
383
384	161x	x[1] <- Find(function(i) i <= x[1], range, nomatch = min(range), right = TRUE)
385	161x	x[2] <- Find(function(i) i >= x[2], range, nomatch = max(range))
386	161x	x
387		}

1		#' @title `FilterStates` R6 class
2		#'
3		#' @description
4		#' Abstract class that manages adding and removing `FilterState` objects
5		#' and builds a \emph{subset expression}.
6		#'
7		#' A `FilterStates` object tracks all subsetting expressions
8		#' (logical predicates that limit observations) associated with a given dataset
9		#' and composes them into a single reproducible R expression
10		#' that will assign a subset of the original data to a new variable.
11		#' This expression is hereafter referred to as \emph{subset expression}.
12		#'
13		#' The \emph{subset expression} is constructed differently for different
14		#' classes of the underlying data object and `FilterStates` subclasses.
15		#' Currently implemented for `data.frame`, `matrix`,
16		#' `SummarizedExperiment`, and `MultiAssayExperiment`.
17		#'
18		#' @keywords internal
19		#'
20		#' @examples
21		#' library(shiny)
22		#' filter_states <- teal.slice:::DFFilterStates$new(
23		#' dataname = "data",
24		#' varlabels = c(x = "x variable", SEX = "Sex"),
25		#' datalabel = character(0),
26		#' keys = character(0)
27		#' )
28		#' filter_state <- teal.slice:::RangeFilterState$new(
29		#' c(NA, Inf, seq(1:10)),
30		#' varname = "x",
31		#' varlabel = "x variable",
32		#' dataname = "data",
33		#' extract_type = "list"
34		#' )
35		#' isolate(filter_state$set_selected(c(3L, 8L)))
36		#'
37		#' isolate(
38		#' filter_states$state_list_push(
39		#' x = filter_state,
40		#' state_list_index = 1L,
41		#' state_id = "x"
42		#' )
43		#' )
44		#' isolate(filter_states$get_call())
45		#'
46		FilterStates <- R6::R6Class( # nolint
47		classname = "FilterStates",
48
49		# public members ----
50		public = list(
51		#' @description
52		#' Initializes `FilterStates` object.
53		#'
54		#' Initializes `FilterStates` object by setting
55		#' `dataname`, and `datalabel`.
56		#'
57		#' @param dataname (`character(1)`)\cr
58		#' name of the data used in the expression
59		#' specified to the function argument attached to this `FilterStates`
60		#' @param datalabel (`character(0)` or `character(1)`)\cr
61		#' text label value
62		#'
63		#' @return
64		#' self invisibly
65		#'
66		initialize = function(dataname, datalabel) {
67	392x	checkmate::assert_string(dataname)
68	390x	checkmate::assert_character(datalabel, max.len = 1, any.missing = FALSE)
69
70	390x	private$dataname <- dataname
71	390x	private$datalabel <- datalabel
72
73	390x	logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
74	390x	invisible(self)
75		},
76
77		#' @description
78		#' Returns the label of the dataset.
79		#'
80		#' @return `character(1)` the data label
81		#'
82		get_datalabel = function() {
83	5x	private$datalabel
84		},
85
86		#' @description
87		#' Returns a formatted string representing this `FilterStates` object.
88		#'
89		#' @param indent (`numeric(1)`) the number of spaces prepended to each line of the output
90		#'
91		#' @return `character(1)` the formatted string
92		#'
93		format = function(indent) {
94	!	sprintf(
95	!	paste(
96	!	"%sThis is an instance of an abstract class.",
97	!	"Use child class constructors to instantiate objects."
98		),
99	!	paste(rep(" ", indent), collapse = "")
100		)
101		},
102
103		#' @description
104		#' Filter call
105		#'
106		#' Builds \emph{subset expression} from condition calls stored in `FilterState`
107		#' objects selection. The `lhs` of the expression is `private$dataname`.
108		#' The `rhs` is a call to `self$get_fun()` with `private$dataname`
109		#' as argument and a list of condition calls from `FilterState` objects
110		#' stored in `private$state_list`.
111		#' If no filters are applied,
112		#' `NULL` is returned to avoid no-op calls such as `x <- x`.
113		#'
114		#' @return `call` or `NULL`
115		#'
116		get_call = function() {
117		# state_list (list) names must be the same as argument of the function
118		# for ... list should be unnamed
119	120x	states_list <- private$state_list
120	120x	filter_items <- sapply(
121	120x	X = states_list,
122	120x	USE.NAMES = TRUE,
123	120x	simplify = FALSE,
124	120x	function(state_list) {
125	165x	items <- state_list()
126	165x	filtered_items <- Filter(f = function(x) x$is_any_filtered(), x = items)
127	165x	calls <- lapply(
128	165x	filtered_items,
129	165x	function(state) {
130	68x	state$get_call()
131		}
132		)
133	165x	calls_combine_by(calls, operator = "&")
134		}
135		)
136	120x	filter_items <- Filter(
137	120x	x = filter_items,
138	120x	f = Negate(is.null)
139		)
140	120x	if (length(filter_items) > 0L) {
141	44x	filter_function <- str2lang(self$get_fun())
142	44x	data_name <- str2lang(private$dataname)
143	44x	substitute(
144	44x	env = list(
145	44x	lhs = data_name,
146	44x	rhs = as.call(c(filter_function, c(list(data_name), filter_items)))
147		),
148	44x	expr = lhs <- rhs
149		)
150		} else {
151		# return NULL to avoid no-op call
152	76x	NULL
153		}
154		},
155
156		#' @description
157		#' Prints this `FilterStates` object.
158		#'
159		#' @param ... additional arguments to this method
160		print = function(...) {
161	!	cat(shiny::isolate(self$format()), "\n")
162		},
163
164		#' @description
165		#' Gets the name of the function used to filter the data in this `FilterStates`.
166		#'
167		#' Get name of function used to create the \emph{subset expression}.
168		#' Defaults to "subset" but can be overridden by child class method.
169		#'
170		#' @return `character(1)` the name of the function
171		#'
172		get_fun = function() {
173	12x	"subset"
174		},
175
176		# state_list methods ----
177
178		#' @description
179		#' Returns a list of `FilterState` objects stored in this `FilterStates`.
180		#'
181		#' @param state_list_index (`character(1)`, `integer(1)`)\cr
182		#' index on the list in `private$state_list` where filter states are kept
183		#' @param state_id (`character(1)`)\cr
184		#' name of element in a filter state (which is a `reactiveVal` containing a list)
185		#'
186		#' @return `list` of `FilterState` objects
187		#'
188		state_list_get = function(state_list_index, state_id = NULL) {
189	503x	private$validate_state_list_exists(state_list_index)
190	501x	checkmate::assert_string(state_id, null.ok = TRUE)
191
192	501x	if (is.null(state_id)) {
193	498x	private$state_list[[state_list_index]]()
194		} else {
195	3x	private$state_list[[state_list_index]]()[[state_id]]
196		}
197		},
198
199		#' @description
200		#' Adds a new `FilterState` object to this `FilterStates`.\cr
201		#' Raises error if the length of `x` does not match the length of `state_id`.
202		#'
203		#' @param x (`FilterState`)\cr
204		#' object to be added to filter state list
205		#' @param state_list_index (`character(1)`, `integer(1)`)\cr
206		#' index on the list in `private$state_list` where filter states are kept
207		#' @param state_id (`character(1)`)\cr
208		#' name of element in a filter state (which is a `reactiveVal` containing a list)
209		#'
210		#' @return NULL
211		#'
212		state_list_push = function(x, state_list_index, state_id) {
213	206x	logger::log_trace(
214	206x	"{ class(self)[1] } pushing into state_list, dataname: { private$dataname }"
215		)
216	206x	private$validate_state_list_exists(state_list_index)
217	205x	checkmate::assert_string(state_id)
218
219	205x	states <- if (is.list(x)) {
220	!	x
221		} else {
222	205x	list(x)
223		}
224
225	205x	state <- stats::setNames(states, state_id)
226	205x	new_state_list <- c(private$state_list[[state_list_index]](), state)
227	205x	private$state_list[[state_list_index]](new_state_list)
228
229	205x	logger::log_trace(
230	205x	"{ class(self)[1] } pushed into queue, dataname: { private$dataname }"
231		)
232	205x	invisible(NULL)
233		},
234
235		#' @description
236		#' Removes a single filter state with all associated shiny elements:\cr
237		#' * specified `FilterState` from `private$state_list`
238		#' * UI card created for this filter
239		#' * observers tracking the selection and remove button
240		#'
241		#' @param state_list_index (`character(1)`, `integer(1)`)\cr
242		#' index on the list in `private$state_list` where filter states are kept
243		#' @param state_id (`character(1)`)\cr
244		#' name of element in a filter state (which is a `reactiveVal` containing a list)
245		#'
246		#' @return NULL
247		#'
248		state_list_remove = function(state_list_index, state_id) {
249	28x	logger::log_trace(paste(
250	28x	"{ class(self)[1] } removing a filter from state_list { state_list_index },",
251	28x	"dataname: { private$dataname }"
252		))
253	28x	private$validate_state_list_exists(state_list_index)
254	27x	checkmate::assert_string(state_id)
255	27x	checkmate::assert(
256	27x	checkmate::check_string(state_list_index),
257	27x	checkmate::check_int(state_list_index)
258		)
259
260	27x	new_state_list <- private$state_list[[state_list_index]]()
261	27x	new_state_list[[state_id]] <- NULL
262	27x	private$state_list[[state_list_index]](new_state_list)
263
264	27x	logger::log_trace(paste(
265	27x	"{ class(self)[1] } removed from state_list { state_list_index },",
266	27x	"dataname: { private$dataname }"
267		))
268	27x	invisible(NULL)
269		},
270
271		#' @description
272		#' Remove all `FilterState` objects from this `FilterStates` object.
273		#'
274		#' @return NULL
275		#'
276		state_list_empty = function() {
277	24x	logger::log_trace(
278	24x	"{ class(self)[1] } emptying state_list, dataname: { private$dataname }"
279		)
280
281	24x	for (i in seq_along(private$state_list)) {
282	28x	private$state_list[[i]](list())
283		}
284
285	24x	logger::log_trace(
286	24x	"{ class(self)[1] } emptied state_list, dataname: { private$dataname }"
287		)
288	24x	invisible(NULL)
289		},
290
291		#' @description
292		#' Gets the number of active `FilterState` objects in this `FilterStates` object.
293		#'
294		#' @return `integer(1)`
295		#'
296		get_filter_count = function() {
297	66x	sum(vapply(private$state_list, function(state_list) {
298	103x	length(state_list())
299	66x	}, FUN.VALUE = integer(1)))
300		},
301
302		#' @description Remove a single `FilterState` from `state_list`.
303		#'
304		#' @param state_id (`character`)\cr
305		#' name of variable for which to remove `FilterState`
306		#'
307		#' @return `NULL`
308		#'
309		remove_filter_state = function(state_id) {
310	!	stop("This variable can not be removed from the filter.")
311		},
312
313		# shiny modules ----
314
315		#' @description
316		#' Shiny module UI
317		#'
318		#' Shiny UI element that stores `FilterState` UI elements.
319		#' Populated with elements created with `renderUI` in the module server.
320		#'
321		#' @param id (`character(1)`)\cr
322		#' shiny element (module instance) id
323		#'
324		#' @return `shiny.tag`
325		#'
326		ui = function(id) {
327	!	ns <- NS(id)
328	!	private$cards_container_id <- ns("cards")
329	!	tagList(
330	!	include_css_files(pattern = "filter-panel"),
331	!	tags$div(
332	!	id = private$cards_container_id,
333	!	class = "list-group hideable-list-group",
334	!	`data-label` = ifelse(private$datalabel == "", "", (paste0("> ", private$datalabel)))
335		)
336		)
337		},
338
339		#' @description
340		#' Gets reactive values from active `FilterState` objects.
341		#'
342		#' Get active filter state from `FilterState` objects stored in `state_list`(s).
343		#' The output is a list compatible with input to `self$set_filter_state`.
344		#'
345		#' @return `list` containing `list` per `FilterState` in the `state_list`
346		#'
347		get_filter_state = function() {
348	!	stop("Pure virtual method.")
349		},
350
351		#' @description
352		#' Sets active `FilterState` objects.
353		#'
354		#' @param data (`data.frame`)\cr
355		#' data object for which to define a subset
356		#' @param state (`named list`)\cr
357		#' should contain values of initial selections in the `FilterState`;
358		#' `list` names must correspond to column names in `data`
359		#' @param filtered_dataset
360		#' data object for which to define a subset(?)
361		#'
362		set_filter_state = function(data, state, filtered_dataset) {
363	!	stop("Pure virtual method.")
364		},
365
366		#' @description
367		#' Shiny module UI that adds a filter variable.
368		#'
369		#' @param id (`character(1)`)\cr
370		#' shiny element (module instance) id
371		#' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr
372		#' data object for which to define a subset
373		#'
374		#' @return `shiny.tag`
375		#'
376		ui_add_filter_state = function(id, data) {
377	!	div("This object cannot be filtered")
378		},
379
380		#' @description
381		#' Shiny module server that adds a filter variable.
382		#'
383		#' @param id (`character(1)`)\cr
384		#' shiny module instance id
385		#' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr
386		#' data object for which to define a subset
387		#' @param ... ignored
388		#'
389		#' @return `moduleServer` function which returns `NULL`
390		#'
391		srv_add_filter_state = function(id, data, ...) {
392	!	check_ellipsis(..., stop = FALSE)
393	!	moduleServer(
394	!	id = id,
395	!	function(input, output, session) {
396	!	NULL
397		}
398		)
399		}
400		),
401		private = list(
402		# private fields ----
403		cards_container_id = character(0),
404		card_ids = character(0),
405		datalabel = character(0),
406		dataname = NULL, # because it holds object of class name
407		ns = NULL, # shiny ns()
408		observers = list(), # observers
409		state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes
410
411		# private methods ----
412
413		# Module to insert/remove `FilterState` UI
414		#
415		# This module adds the shiny UI of the `FilterState` object newly added
416		# to state_list to the Active Filter Variables,
417		# calls `FilterState` modules and creates an observer to remove state
418		# parameter filter_state (`FilterState`).
419		#
420		# @param id (`character(1)`)\cr
421		# shiny module instance id
422		# @param filter_state (`named list`)\cr
423		# should contain values of initial selections in the `FilterState`;
424		# `list` names must correspond to column names in `data`
425		# @param state_list_index (`character(1)`, `integer(1)`)\cr
426		# index on the list in `private$state_list` where filter states are kept
427		# @param state_id (`character(1)`)\cr
428		# name of element in a filter state (which is a `reactiveVal` containing a list)
429		#
430		# @return `moduleServer` function which returns `NULL`
431		#
432		insert_filter_state_ui = function(id, filter_state, state_list_index, state_id) {
433	!	checkmate::assert_class(filter_state, "FilterState")
434	!	checkmate::assert(
435	!	checkmate::check_int(state_list_index),
436	!	checkmate::check_character(state_list_index, len = 1),
437	!	combine = "or"
438		)
439	!	checkmate::assert_character(state_id, len = 1)
440	!	moduleServer(
441	!	id = id,
442	!	function(input, output, session) {
443	!	logger::log_trace(
444	!	sprintf(
445	!	"%s$insert_filter_state_ui, adding FilterState UI of variable %s, dataname: %s",
446	!	class(self)[1],
447	!	state_id,
448	!	private$dataname
449		)
450		)
451
452		# card_id of inserted card must be saved in private$card_ids as
453		# it might be removed by the several events:
454		# - remove button in FilterStates module
455		# - remove button in FilteredDataset module
456		# - remove button in FilteredData module
457		# - API call remove_filter_state
458	!	card_id <- session$ns("card")
459	!	state_list_id <- sprintf("%s-%s", state_list_index, state_id)
460	!	private$card_ids[state_list_id] <- card_id
461
462	!	insertUI(
463	!	selector = sprintf("#%s", private$cards_container_id),
464	!	where = "beforeEnd",
465		# add span with id to be removable
466	!	ui = div(
467	!	id = card_id,
468	!	class = "list-group-item",
469	!	filter_state$ui(session$ns("content"))
470		)
471		)
472		# signal sent from filter_state when it is marked for removal
473	!	remove_fs <- filter_state$server(id = "content")
474
475	!	private$observers[[state_list_id]] <- observeEvent(
476	!	ignoreInit = TRUE,
477	!	ignoreNULL = TRUE,
478	!	eventExpr = remove_fs(),
479	!	handlerExpr = {
480	!	logger::log_trace(paste(
481	!	"{ class(self)[1] }$insert_filter_state_ui@1",
482	!	"removing FilterState from state_list '{ state_list_index }',",
483	!	"dataname: { private$dataname }"
484		))
485	!	self$state_list_remove(state_list_index, state_id)
486	!	logger::log_trace(paste(
487	!	"{ class(self)[1] }$insert_filter_state_ui@1",
488	!	"removed FilterState from state_list '{ state_list_index }',",
489	!	"dataname: { private$dataname }"
490		))
491		}
492		)
493
494	!	logger::log_trace(
495	!	sprintf(
496	!	"%s$insert_filter_state_ui, added FilterState UI of variable %s, dataname: %s",
497	!	class(self)[1],
498	!	state_id,
499	!	private$dataname
500		)
501		)
502	!	NULL
503		}
504		)
505		},
506
507		# Remove shiny element. Method can be called from reactive session where
508		# `observeEvent` for remove-filter-state is set and also from `FilteredDataset`
509		# level, where shiny-session-namespace is different. That is why it's important
510		# to remove shiny elements from anywhere. In `add_filter_state` `session$ns(NULL)`
511		# is equivalent to `private$ns(state_list_index)`.
512		# In addition, an unused reactive is being removed from input:
513		# method searches input for the unique matches with the filter name
514		# and then removes objects constructed with current card id + filter name.
515		#
516		remove_filter_state_ui = function(state_list_index, state_id, .input) {
517	4x	state_list_id <- sprintf("%s-%s", state_list_index, state_id)
518	4x	removeUI(selector = sprintf("#%s", private$card_ids[state_list_id]))
519	4x	private$card_ids <- private$card_ids[names(private$card_ids) != state_list_id]
520	4x	if (length(private$observers[[state_list_id]]) > 0) {
521	!	private$observers[[state_list_id]]$destroy()
522	!	private$observers[[state_list_id]] <- NULL
523		}
524		# Remove unused reactive from shiny input (leftover of removeUI).
525		# This default behavior may change in the future, making this part obsolete.
526	4x	prefix <- paste0(gsub("cards$", "", private$cards_container_id))
527	4x	invisible(
528	4x	lapply(
529	4x	unique(grep(state_id, names(.input), value = TRUE)),
530	4x	function(i) {
531	!	.subset2(.input, "impl")$.values$remove(paste0(prefix, i))
532		}
533		)
534		)
535		},
536		# Checks if the state_list of the given index was initialized in this `FilterStates`
537		# @param state_list_index (character or integer)
538		validate_state_list_exists = function(state_list_index) {
539	737x	checkmate::assert(
540	737x	checkmate::check_string(state_list_index),
541	737x	checkmate::check_int(state_list_index)
542		)
543		if (
544		!(
545	737x	is.numeric(state_list_index) &&
546	737x	all(state_list_index <= length(private$state_list) && state_list_index > 0) \|\|
547	737x	is.character(state_list_index) && all(state_list_index %in% names(private$state_list))
548		)
549		) {
550	4x	stop(
551	4x	paste(
552	4x	"Filter state list",
553	4x	state_list_index,
554	4x	"has not been initialized in FilterStates object belonging to the dataset",
555	4x	private$datalabel
556		)
557		)
558		}
559		},
560
561		# Maps the array of strings to sanitized unique HTML ids.
562		# @param keys `character` the array of strings
563		# @param prefix `character(1)` text to prefix id. Needed in case of multiple
564		# state_list objects where keys (variables) might be duplicated across state_lists
565		# @return `list` the mapping
566		map_vars_to_html_ids = function(keys, prefix = "") {
567	10x	checkmate::assert_character(keys, null.ok = TRUE)
568	10x	checkmate::assert_character(prefix, len = 1)
569	10x	sanitized_values <- make.unique(gsub("[^[:alnum:]]", perl = TRUE, replacement = "", x = keys))
570	10x	sanitized_values <- paste(prefix, "var", sanitized_values, sep = "_")
571	10x	stats::setNames(object = sanitized_values, nm = keys)
572		}
573		)
574		)

1		#' @name CDISCFilteredData
2		#' @docType class
3		#'
4		#' @title Class to encapsulate relational filtered datasets with its parents.
5		#' @description `r lifecycle::badge("stable")`
6		#' @details
7		#' The `CDISCFilteredData` class implements logic to filter a relational
8		#' dataset by inheriting from `FilteredData`.
9		#' A dataset can have up to one parent dataset. Rows are identified by the foreign
10		#' key and only those rows that appear in the parent dataset are kept in the filtered
11		#' dataset.
12		#'
13		#' The teal UI works with objects of class `FilteredData` which may mix CDISC and other
14		#' data (e.g. `iris`).
15		#'
16		#' @seealso `FilteredData` class
17		#'
18		#' @examples
19		#' library(scda)
20		#' library(teal.data)
21		#'
22		#' ADSL <- synthetic_cdisc_data("latest")$adsl
23		#' ADTTE <- synthetic_cdisc_data("latest")$adtte
24		#' datasets <- teal.slice:::CDISCFilteredData$new(
25		#' list(
26		#' ADSL = list(dataset = ADSL, keys = c("STUDYID", "USUBJID")),
27		#' ADTTE = list(dataset = ADTTE, keys = c("STUDYID", "USUBJID", "PARAMCD"), parent = "ADSL")
28		#' ),
29		#' check = FALSE,
30		#' join_keys = join_keys(join_key("ADSL", "ADTTE", c("STUDYID", "USUBJID")))
31		#' )
32		#'
33		#' # to avoid using isolate(), you can provide a default isolate context by calling
34		#' # options(shiny.suppressMissingContextError = TRUE) #nolint
35		#' # don't forget to deactivate this option at the end
36		#' # options(shiny.suppressMissingContextError = FALSE) #nolint
37		#'
38		#' isolate({
39		#' datasets$datanames()
40		#'
41		#' # number observations and subjects of filtered/non-filtered dataset
42		#' datasets$get_filter_overview("ADSL")
43		#'
44		#' print(datasets$get_call("ADSL"))
45		#' print(datasets$get_call("ADTTE"))
46		#'
47		#' df <- datasets$get_data("ADSL", filtered = FALSE)
48		#' print(df)
49		#' })
50		#'
51		#'
52		#' isolate(datasets$set_filter_state(list(ADTTE = list(PARAMCD = "OS"))))
53		#' isolate(datasets$get_filter_state())
54		CDISCFilteredData <- R6::R6Class( # nolint
55		"CDISCFilteredData",
56		inherit = FilteredData,
57		## CDISCFilteredData ====
58		## __Public Methods ====
59		public = list(
60		#' @description
61		#' Get datanames
62		#'
63		#' The datanames are returned in the order in which they must be
64		#' evaluated (in case of dependencies).
65		#' @return (`character` vector) of datanames
66		datanames = function() {
67	15x	datanames <- super$datanames()
68	15x	child_parent <- sapply(datanames, function(i) self$get_parentname(i), USE.NAMES = TRUE, simplify = FALSE)
69	15x	ordered_datanames <- topological_sort(child_parent)
70	15x	return(as.character(intersect(as.character(ordered_datanames), datanames)))
71		},
72
73		#' @description
74		#'
75		#' Produces language required to filter a single dataset and merge it with its parent.
76		#' The datasets in question are assumed to be available.
77		#'
78		#' @param dataname (`character(1)`) name of the dataset
79		#' @return (`call` or `list` of calls ) to filter dataset
80		#'
81		get_call = function(dataname) {
82	13x	parent_dataname <- self$get_parentname(dataname)
83
84	13x	if (length(parent_dataname) == 0) {
85	12x	super$get_call(dataname)
86		} else {
87	1x	dataset <- self$get_filtered_dataset(dataname)
88	1x	premerge_call <- Filter(
89	1x	f = Negate(is.null),
90	1x	x = lapply(
91	1x	dataset$get_filter_states(),
92	1x	function(x) x$get_call()
93		)
94		)
95
96	1x	join_keys <- self$get_join_keys()
97	1x	keys <-
98	1x	if (!is.null(join_keys)) {
99	1x	join_keys$get(parent_dataname, dataname)
100		} else {
101	!	character(0)
102		}
103	1x	parent_keys <- names(keys)
104	1x	dataset_keys <- unname(keys)
105
106	1x	y_arg <-
107	1x	if (length(parent_keys) == 0L) {
108	!	parent_dataname
109		} else {
110	1x	sprintf("%s[, c(%s), drop = FALSE]", parent_dataname, toString(dQuote(parent_keys, q = FALSE)))
111		}
112	1x	more_args <-
113	1x	if (length(parent_keys) == 0 \|\| length(dataset_keys) == 0) {
114	!	list()
115	1x	} else if (identical(parent_keys, dataset_keys)) {
116	1x	list(by = parent_keys)
117		} else {
118	!	list(by = stats::setNames(parent_keys, dataset_keys))
119		}
120
121	1x	merge_call <- call(
122		"<-",
123	1x	as.name(dataname),
124	1x	as.call(
125	1x	c(
126	1x	str2lang("dplyr::inner_join"),
127	1x	x = as.name(dataname),
128	1x	y = str2lang(y_arg),
129	1x	more_args
130		)
131		)
132		)
133
134	1x	c(premerge_call, merge_call)
135		}
136		},
137
138		#' @description
139		#' Get names of datasets available for filtering
140		#'
141		#' @param dataname (`character` vector) names of the dataset
142		#' @return (`character` vector) of dataset names
143		get_filterable_datanames = function(dataname) {
144	!	parents <- character(0)
145	!	for (i in dataname) {
146	!	while (length(i) > 0) {
147	!	parent_i <- self$get_parentname(i)
148	!	parents <- c(parents, parent_i)
149	!	i <- parent_i
150		}
151		}
152
153	!	return(unique(c(parents, dataname)))
154		},
155
156		#' @description
157		#' Gets variable names of a given dataname for the filtering. This excludes parent dataset variable names.
158		#'
159		#' @param dataname (`character(1)`) name of the dataset
160		#' @return (`character` vector) of variable names
161		get_filterable_varnames = function(dataname) {
162	8x	varnames <- self$get_filtered_dataset(dataname)$get_filterable_varnames()
163	8x	parent_dataname <- self$get_parentname(dataname)
164	8x	parent_varnames <- if (length(parent_dataname) > 0) {
165		# cannot call get_filterable_varnames on the parent filtered_dataset in case
166		# some of its variables are set to be non-filterable
167	5x	get_supported_filter_varnames(self$get_filtered_dataset(parent_dataname))
168		}
169	8x	setdiff(varnames, parent_varnames)
170		},
171
172		#' @description
173		#' Get filter overview table in form of X (filtered) / Y (non-filtered)
174		#'
175		#' This is intended to be presented in the application.
176		#'
177		#' @param datanames (`character` vector) names of the dataset (or "all")
178		#'
179		#' @return (`matrix`) matrix of observations and subjects of all datasets
180		get_filter_overview = function(datanames) {
181	10x	if (identical(datanames, "all")) {
182	1x	datanames <- self$datanames()
183		}
184	9x	check_in_subset(datanames, self$datanames(), "Some datasets are not available: ")
185
186	6x	rows <- lapply(
187	6x	datanames,
188	6x	function(dataname) {
189	12x	obs <- self$get_filtered_dataset(dataname)$get_filter_overview_info(
190	12x	filtered_dataset = self$get_data(dataname = dataname, filtered = TRUE)
191	12x	)[, 1]
192
193	12x	subs <- private$get_filter_overview_nsubjs(dataname)
194
195	12x	df <- cbind(
196	12x	obs, subs
197		)
198
199	12x	rownames(df) <- if (!is.null(names(obs))) {
200	4x	names(obs)
201		} else {
202	8x	dataname
203		}
204	12x	colnames(df) <- c("Obs", "Subjects")
205	12x	df
206		}
207		)
208
209	6x	do.call(rbind, rows)
210		},
211
212		#' @description
213		#' Get parent dataset name
214		#'
215		#' @param dataname (`character(1)`) name of the dataset
216		#' @return (`character`) name of parent dataset
217		get_parentname = function(dataname) {
218	77x	private$parents[[dataname]]
219		},
220
221		#' @description
222		#' Add dataset
223		#'
224		#' Add dataset and preserve all attributes attached to this object.
225		#' Technically `set_dataset` created `FilteredDataset` which keeps
226		#' `dataset` for filtering purpose.
227		#'
228		#' @param dataset_args (`list`)\cr
229		#' containing the arguments except (`dataname`)
230		#' needed by `init_filtered_dataset` (can also
231		#' include `parent` which will be ignored)
232		#' @param dataname (`character(1)`)\cr
233		#' the name of the `dataset` to be added to this object
234		#' @return (`self`) object of this class
235		set_dataset = function(dataset_args, dataname) {
236	40x	logger::log_trace("CDISCFilteredData$set_dataset setting dataset, name: { dataname }")
237	40x	validate_dataset_args(dataset_args, dataname, allowed_parent = TRUE)
238
239	40x	parent_dataname <- dataset_args[["parent"]]
240	40x	dataset_args[["parent"]] <- NULL
241	40x	private$parents[[dataname]] <- parent_dataname
242
243	40x	if (length(parent_dataname) == 0) {
244	30x	super$set_dataset(dataset_args, dataname)
245		} else {
246	10x	dataset <- dataset_args[["dataset"]]
247	10x	dataset_args[["dataset"]] <- NULL
248
249		# to include it nicely in the Show R Code; the UI also uses datanames in ids, so no whitespaces allowed
250	10x	check_simple_name(dataname)
251	10x	private$filtered_datasets[[dataname]] <- do.call(
252	10x	what = init_filtered_dataset,
253	10x	args = c(list(dataset), dataset_args, list(dataname = dataname))
254		)
255
256	10x	private$reactive_data[[dataname]] <- reactive({
257	!	env <- new.env(parent = parent.env(globalenv()))
258	!	env[[dataname]] <- self$get_filtered_dataset(dataname)$get_dataset()
259	!	env[[private$parents[[dataname]]]] <-
260	!	private$reactive_data[[private$parents[[dataname]]]]()
261
262	!	filter_call <- self$get_call(dataname)
263	!	eval_expr_with_msg(filter_call, env)
264	!	get(x = dataname, envir = env)
265		})
266		}
267
268	40x	invisible(self)
269		}
270		),
271
272		## __Private Methods---------------------
273		private = list(
274
275		# named list of dataset parents parents[[child_dataset]] = its parent
276		parents = NULL,
277
278		# datanames in the order in which they must be evaluated (in case of dependencies)
279		# this is a reactive and kept as a field for caching
280		ordered_datanames = NULL,
281		validate = function() {
282	!	stopifnot(
283	!	setequal(private$ordered_datanames, names(private$dataset_filters)),
284		)
285	!	super$validate()
286		},
287		get_filter_overview_nsubjs = function(dataname) {
288		# Gets filter overview subjects number and returns a list
289		# of the number of subjects of filtered/non-filtered datasets
290	12x	subject_keys <- if (length(self$get_parentname(dataname)) > 0) {
291	!	self$get_keys(self$get_parentname(dataname))
292		} else {
293	12x	self$get_filtered_dataset(dataname)$get_keys()
294		}
295
296	12x	self$get_filtered_dataset(dataname)$get_filter_overview_nsubjs(
297	12x	self$get_data(dataname = dataname, filtered = TRUE),
298	12x	subject_keys
299		)
300		}
301		)
302		)
303
304		#' Topological graph sort
305		#'
306		#' Graph is a list which for each node contains a vector of child nodes
307		#' in the returned list, parents appear before their children.
308		#'
309		#' Implementation of Kahn algorithm with a modification to maintain the order of input elements.
310		#'
311		#' @param graph (named `list`) list with node vector elements
312		#' @keywords internal
313		#'
314		#' @examples
315		#' \dontrun{
316		#' topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
317		#' topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
318		#' topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
319		#' }
320		topological_sort <- function(graph) {
321		# compute in-degrees
322	15x	in_degrees <- list()
323	15x	for (node in names(graph)) {
324	42x	in_degrees[[node]] <- 0
325	42x	for (to_edge in graph[[node]]) {
326	3x	in_degrees[[to_edge]] <- 0
327		}
328		}
329
330	15x	for (node in graph) {
331	42x	for (to_edge in node) {
332	3x	in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1
333		}
334		}
335
336		# sort
337	15x	visited <- 0
338	15x	sorted <- list()
339	15x	zero_in <- list()
340	15x	for (node in names(in_degrees)) {
341	39x	if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node)
342		}
343	15x	zero_in <- rev(zero_in)
344
345	15x	while (length(zero_in) != 0) {
346	42x	visited <- visited + 1
347	42x	sorted <- c(zero_in[[1]], sorted)
348	42x	for (edge_to in graph[[zero_in[[1]]]]) {
349	3x	in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1
350	3x	if (in_degrees[[edge_to]] == 0) {
351	3x	zero_in <- append(zero_in, edge_to, 1)
352		}
353		}
354	42x	zero_in[[1]] <- NULL
355		}
356
357	15x	if (visited != length(in_degrees)) {
358	!	stop(
359	!	"Graph is not a directed acyclic graph. Cycles involving nodes: ",
360	!	paste0(setdiff(names(in_degrees), sorted), collapse = " ")
361		)
362		} else {
363	15x	return(sorted)
364		}
365		}

1		#' @name FilterState
2		#' @docType class
3		#'
4		#'
5		#' @title FilterState Abstract Class
6		#'
7		#' @description Abstract class to encapsulate filter states
8		#'
9		#' @details
10		#' This class is responsible for managing single filter item within
11		#' `FilteredData` class. Filter states depend on the variable type:
12		#' (`logical`, `integer`, `numeric`, `factor`, `character`, `Date`, `POSIXct`, `POSIXlt`)
13		#' and returns `FilterState` object with class corresponding to input variable.
14		#' Class controls single filter entry in `module_single_filter_item` and returns
15		#' code relevant to selected values.
16		#' - `factor`, `character`: `class = ChoicesFilterState`
17		#' - `numeric`: `class = RangeFilterState`
18		#' - `logical`: `class = LogicalFilterState`
19		#' - `Date`: `class = DateFilterState`
20		#' - `POSIXct`, `POSIXlt`: `class = DatetimeFilterState`
21		#' - all `NA` entries: `class: FilterState`, cannot be filtered
22		#' - default: `FilterState`, cannot be filtered
23		#' \cr
24		#' Each variable's filter state is an `R6` object which contains `choices`,
25		#' `selected`, `varname`, `dataname`, `labels`, `na_count`, `keep_na` and other
26		#' variable type specific fields (`keep_inf`, `inf_count`, `timezone`).
27		#' Object contains also shiny module (`ui` and `server`) which manages
28		#' state of the filter through reactive values `selected`, `keep_na`, `keep_inf`
29		#' which trigger `get_call()` and every R function call up in reactive
30		#' chain.
31		#' \cr
32		#' \cr
33		#' @section Modifying state:
34		#' Modifying a `FilterState` object is possible in three scenarios:
35		#' * In the interactive session by directly specifying values of `selected`,
36		#' `keep_na` or `keep_inf` using `set_state` method (to update all at once),
37		#' or using `set_selected`, `set_keep_na` or `set_keep_inf`
38		#' * In a running application by changing appropriate inputs
39		#' * In a running application by using [filter_state_api] which directly uses `set_state` method
40		#' of the `FilterState` object.
41		#'
42		#' @keywords internal
43		FilterState <- R6::R6Class( # nolint
44		"FilterState",
45
46		# public methods ----
47		public = list(
48		#' @description
49		#' Initialize a `FilterState` object
50		#' @param x (`vector`)\cr
51		#' values of the variable used in filter
52		#' @param varname (`character`)\cr
53		#' name of the variable
54		#' @param varlabel (`character(1)`)\cr
55		#' label of the variable (optional).
56		#' @param dataname (`character(1)`)\cr
57		#' name of dataset where `x` is taken from. Must be specified if `extract_type` argument
58		#' is not empty.
59		#' @param extract_type (`character(0)`, `character(1)`)\cr
60		#' whether condition calls should be prefixed by dataname. Possible values:
61		#' \itemize{
62		#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
63		#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
64		#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
65		#' }
66		#'
67		#' @return self invisibly
68		#'
69		initialize = function(x,
70		varname,
71		varlabel = character(0),
72		dataname = NULL,
73		extract_type = character(0)) {
74	356x	checkmate::assert_string(varname)
75	353x	checkmate::assert_character(varlabel, max.len = 1, any.missing = FALSE)
76	353x	checkmate::assert_string(dataname, null.ok = TRUE)
77	353x	checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)
78	353x	if (length(extract_type) == 1) {
79	53x	checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
80		}
81	353x	if (length(extract_type) == 1 && is.null(dataname)) {
82	1x	stop("if extract_type is specified, dataname must also be specified")
83		}
84
85	352x	private$dataname <- dataname
86	352x	private$varname <- varname
87	352x	private$varlabel <- if (identical(varlabel, as.character(varname))) {
88		# to not display duplicated label
89	41x	character(0)
90		} else {
91	311x	varlabel
92		}
93	352x	private$extract_type <- extract_type
94	352x	private$selected <- reactiveVal(NULL)
95	352x	private$na_count <- sum(is.na(x))
96	352x	private$keep_na <- reactiveVal(FALSE)
97	352x	logger::log_trace(
98	352x	sprintf(
99	352x	"Instantiated %s with variable %s, dataname: %s",
100	352x	class(self)[1],
101	352x	private$varname,
102	352x	private$dataname
103		)
104		)
105	352x	invisible(self)
106		},
107
108		#' @description
109		#' Destroy observers stored in `private$observers`.
110		#'
111		#' @return NULL invisibly
112		#'
113		destroy_observers = function() {
114	!	lapply(private$observers, function(x) x$destroy())
115	!	return(invisible(NULL))
116		},
117
118		#' @description
119		#' Returns a formatted string representing this `FilterState`.
120		#'
121		#' @param indent (`numeric(1)`)
122		#' number of spaces before after each new line character of the formatted string;
123		#' defaults to 0
124		#' @param wrap_width (`numeric(1)`)
125		#' number of characters to wrap lines at in the printed output;
126		#' allowed range is 30 to 120; defaults to 76
127		#'
128		#' @return `character(1)` the formatted string
129		#'
130		format = function(indent = 0L, wrap_width = 76L) {
131	50x	checkmate::assert_number(indent, finite = TRUE, lower = 0L)
132	49x	checkmate::assert_number(wrap_width, finite = TRUE, lower = 30L, upper = 120L)
133
134		# List all selected values separated by commas.
135	48x	values <- paste(format(self$get_selected(), nsmall = 3L, justify = "none"), collapse = ", ")
136	48x	paste(c(
137	48x	strwrap(
138	48x	sprintf("Filtering on: %s", private$varname),
139	48x	width = wrap_width,
140	48x	indent = indent
141		),
142		# Add wrapping and progressive indent to values enumeration as it is likely to be long.
143	48x	strwrap(
144	48x	sprintf("Selected values: %s", values),
145	48x	width = wrap_width,
146	48x	indent = indent + 2L,
147	48x	exdent = indent + 4L
148		),
149	48x	strwrap(
150	48x	sprintf("Include missing values: %s", self$get_keep_na()),
151	48x	width = wrap_width,
152	48x	indent = indent + 2L
153		)
154	48x	), collapse = "\n")
155		},
156
157		#' @description
158		#' Returns reproducible condition call for current selection relevant
159		#' for selected variable type.
160		#' Method is using internal reactive values which makes it reactive
161		#' and must be executed in reactive or isolated context.
162		#'
163		get_call = function() {
164	1x	NULL
165		},
166
167		#' @description
168		#' Returns dataname or "NULL" if dataname is NULL.
169		#'
170		#' @return `character(1)`
171		#'
172		get_dataname = function() {
173	409x	if (!is.null(private$dataname)) {
174	221x	private$dataname
175		} else {
176	188x	character(1)
177		}
178		},
179
180		#' @description
181		#' Returns current `keep_na` selection.
182		#'
183		#' @return `logical(1)`
184		#'
185		get_keep_na = function() {
186	335x	private$keep_na()
187		},
188
189		#' @description
190		#' Returns variable label.
191		#'
192		#' @return `character(1)`
193		#'
194		get_varlabel = function() {
195	2x	private$varlabel
196		},
197
198		#' @description
199		#' Get variable name.
200		#'
201		#' @return `character(1)`
202		#'
203		get_varname = function() {
204	423x	private$varname
205		},
206
207		#' @description
208		#' Get selected values from `FilterState`.
209		#'
210		#' @return class of the returned object depends of class of the `FilterState`
211		#'
212		get_selected = function() {
213	428x	private$selected()
214		},
215
216		#' @description
217		#' Returns the filtering state.
218		#'
219		#' @return `list` containing values taken from the reactive fields:
220		#' * `selected` (`atomic`) length depends on a `FilterState` variant.
221		#' * `keep_na` (`logical(1)`) whether `NA` should be kept.
222		#'
223		get_state = function() {
224	38x	list(
225	38x	selected = self$get_selected(),
226	38x	keep_na = self$get_keep_na()
227		)
228		},
229
230		#' @description
231		#' Prints this `FilterState` object.
232		#'
233		#' @param ... additional arguments to this method
234		#'
235		print = function(...) {
236	!	cat(shiny::isolate(self$format()), "\n")
237		},
238
239		#' @description
240		#' Set whether to keep NAs.
241		#'
242		#' @param value `logical(1)`\cr
243		#' value(s) which come from the filter selection. Value is set in `server`
244		#' modules after selecting check-box-input in the shiny interface. Values are set to
245		#' `private$keep_na` which is reactive.
246		#'
247		#' @return NULL invisibly
248		#'
249		set_keep_na = function(value) {
250	117x	checkmate::assert_flag(value)
251	117x	private$keep_na(value)
252	117x	logger::log_trace(
253	117x	sprintf(
254	117x	"%s$set_keep_na set for variable %s to %s.",
255	117x	class(self)[1],
256	117x	private$varname,
257	117x	value
258		)
259		)
260	117x	invisible(NULL)
261		},
262
263		#' @description
264		#' Some methods need an additional `!is.na(varame)` condition to drop
265		#' missing values. When `private$na_rm = TRUE`, `self$get_call` returns
266		#' condition extended by `!is.na`.
267		#'
268		#' @param value `logical(1)`\cr
269		#' when `TRUE`, `FilterState$get_call` appends an expression
270		#' removing `NA` values to the filter expression returned by `get_call`
271		#'
272		#' @return NULL invisibly
273		#'
274		set_na_rm = function(value) {
275	48x	checkmate::assert_flag(value)
276	48x	private$na_rm <- value
277	48x	invisible(NULL)
278		},
279
280		#' @description
281		#' Set selection.
282		#'
283		#' @param value (`vector`)\cr
284		#' value(s) that come from filter selection; values are set in the
285		#' module server after a selection is made in the app interface;
286		#' values are stored in `private$selected` which is reactive;
287		#' value types have to be the same as `private$choices`
288		#'
289		#' @return NULL invisibly
290		#'
291		set_selected = function(value) {
292	580x	logger::log_trace(
293	580x	sprintf(
294	580x	"%s$set_selected setting selection of variable %s, dataname: %s.",
295	580x	class(self)[1],
296	580x	private$varname,
297	580x	private$dataname
298		)
299		)
300	580x	value <- private$cast_and_validate(value)
301	577x	value <- private$remove_out_of_bound_values(value)
302	577x	private$validate_selection(value)
303	573x	private$selected(value)
304	573x	logger::log_trace(sprintf(
305	573x	"%s$set_selected selection of variable %s set, dataname: %s",
306	573x	class(self)[1],
307	573x	private$varname,
308	573x	private$dataname
309		))
310	573x	invisible(NULL)
311		},
312
313		#' @description
314		#' Set state.
315		#'
316		#' @param state (`list`)\cr
317		#' contains fields relevant for a specific class:
318		#' \itemize{
319		#' \item{`selected`}{ defines initial selection}
320		#' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
321		#' }
322		#'
323		#' @return NULL invisibly
324		#'
325		set_state = function(state) {
326	191x	logger::log_trace(sprintf(
327	191x	"%s$set_state, dataname: %s setting state of variable %s to: selected=%s, keep_na=%s",
328	191x	class(self)[1],
329	191x	private$dataname,
330	191x	private$varname,
331	191x	paste(state$selected, collapse = " "),
332	191x	state$keep_na
333		))
334	191x	stopifnot(is.list(state) && all(names(state) %in% c("selected", "keep_na")))
335	187x	if (!is.null(state$keep_na)) {
336	68x	self$set_keep_na(state$keep_na)
337		}
338	187x	if (!is.null(state$selected)) {
339	182x	self$set_selected(state$selected)
340		}
341	187x	logger::log_trace(
342	187x	sprintf(
343	187x	"%s$set_state, dataname: %s done setting state for variable %s",
344	187x	class(self)[1],
345	187x	private$dataname,
346	187x	private$varname
347		)
348		)
349	187x	invisible(NULL)
350		},
351
352		#' @description
353		#' Shiny module server.
354		#'
355		#' @param id (`character(1)`)\cr
356		#' shiny module instance id
357		#'
358		#' @return `moduleServer` function which returns reactive value
359		#' signaling that remove button has been clicked
360		#'
361		server = function(id) {
362	!	moduleServer(
363	!	id = id,
364	!	function(input, output, session) {
365	!	private$server_inputs("inputs")
366	!	reactive(input$remove) # back to parent to remove self
367		}
368		)
369		},
370
371		#' @description
372		#' Shiny module UI.
373		#'
374		#' @param id (`character(1)`)\cr
375		#' shiny element (module instance) id;
376		#' the UI for this class contains simple message stating that it is not supported
377		#'
378		ui = function(id) {
379	!	ns <- NS(id)
380	!	fluidPage(
381	!	theme = get_teal_bs_theme(),
382	!	fluidRow(
383	!	column(
384	!	width = 10,
385	!	class = "no-left-right-padding",
386	!	tags$div(
387	!	tags$span(private$varname,
388	!	class = "filter_panel_varname"
389		),
390	!	if (checkmate::test_character(self$get_varlabel(), min.len = 1) &&
391	!	tolower(private$varname) != tolower(self$get_varlabel())) {
392	!	tags$span(self$get_varlabel(), class = "filter_panel_varlabel")
393		}
394		)
395		),
396	!	column(
397	!	width = 2,
398	!	class = "no-left-right-padding",
399	!	actionLink(
400	!	ns("remove"),
401	!	label = "",
402	!	icon = icon("circle-xmark", lib = "font-awesome"),
403	!	class = "remove pull-right"
404		)
405		)
406		),
407	!	private$ui_inputs(ns("inputs"))
408		)
409		}
410		),
411
412		# private members ----
413		private = list(
414		choices = NULL, # because each class has different choices type
415		dataname = character(0),
416		keep_na = NULL, # reactiveVal logical()
417		na_count = integer(0),
418		na_rm = FALSE, # it's logical(1)
419		observers = NULL, # here observers are stored
420		selected = NULL, # because it holds reactiveVal and each class has different choices type
421		varname = character(0),
422		varlabel = character(0),
423		extract_type = logical(0),
424
425		# private methods ----
426
427		# @description
428		# Return variable name prefixed by dataname to be evaluated as extracted object,
429		# for example `data$var`
430		# @return a character string representation of a subset call
431		# that extracts the variable from the dataset
432		get_varname_prefixed = function() {
433	191x	ans <-
434	191x	if (isTRUE(private$extract_type == "list")) {
435	25x	sprintf("%s$%s", private$dataname, private$varname)
436	191x	} else if (isTRUE(private$extract_type == "matrix")) {
437	5x	sprintf("%s[, \"%s\"]", private$dataname, private$varname)
438		} else {
439	161x	private$varname
440		}
441	191x	str2lang(ans)
442		},
443
444		# @description
445		# Adds `is.na(varname)` before existing condition calls if `keep_na` is selected.
446		# Otherwise, if missings are found in the variable `!is.na` will be added
447		# only if `private$na_rm = TRUE`
448		# @return a `call`
449		add_keep_na_call = function(filter_call) {
450	123x	if (isTRUE(self$get_keep_na())) {
451	13x	call("\|", call("is.na", private$get_varname_prefixed()), filter_call)
452	110x	} else if (isTRUE(private$na_rm) && private$na_count > 0L) {
453	5x	call(
454		"&",
455	5x	call("!", call("is.na", private$get_varname_prefixed())),
456	5x	filter_call
457		)
458		} else {
459	105x	filter_call
460		}
461		},
462
463		# Sets `keep_na` field according to observed `input$keep_na`
464		# If `keep_na = TRUE` `is.na(varname)` is added to the returned call.
465		# Otherwise returned call excludes `NA` when executed.
466		observe_keep_na = function(input) {
467
468		},
469
470		# @description
471		# Set choices is supposed to be executed once in the constructor
472		# to define set/range which selection is made from.
473		# parameter choices (`vector`)\cr
474		# class of the vector depends on the `FilterState` class.
475		# @return `NULL`
476		set_choices = function(choices) {
477	295x	private$choices <- choices
478	295x	invisible(NULL)
479		},
480
481		# Checks if the selection is valid in terms of class and length.
482		# It should not return anything but throw an error if selection
483		# has a wrong class or is outside of possible choices
484		validate_selection = function(value) {
485	13x	invisible(NULL)
486		},
487
488		# Filters out erroneous values from an array.
489		#
490		# @param values the array of values
491		#
492		# @return the array of values without elements, which are outside of
493		# the accepted set for this FilterState
494		remove_out_of_bound_values = function(values) {
495	57x	values
496		},
497
498		# Casts an array of values to the type fitting this `FilterState`
499		# and validates the elements of the casted array
500		# satisfy the requirements of this `FilterState`.
501		#
502		# @param values the array of values
503		#
504		# @return the casted array
505		#
506		# @note throws an error if the casting did not execute successfully.
507		cast_and_validate = function(values) {
508	13x	values
509		},
510
511		# shiny modules -----
512		# module with inputs
513		ui_inputs = function(id) {
514	!	stop("abstract class")
515		},
516		# module with inputs
517		server_inputs = function(id) {
518	!	stop("abstract class")
519		},
520
521		# @description
522		# module displaying input to keep or remove NA in the FilterState call
523		# @param id `shiny` id parameter
524		# renders checkbox input only when variable from which FilterState has
525		# been created has some NA values.
526		keep_na_ui = function(id) {
527	!	ns <- NS(id)
528	!	if (private$na_count > 0) {
529	!	checkboxInput(
530	!	ns("value"),
531	!	sprintf("Keep NA (%s)", private$na_count),
532	!	value = self$get_keep_na()
533		)
534		} else {
535	!	NULL
536		}
537		},
538
539		# @description
540		# module to handle NA values in the FilterState
541		# @param shiny `id` parameter passed to moduleServer
542		# module sets `private$keep_na` according to the selection.
543		# Module also updates a UI element if the `private$keep_na` has been
544		# changed through the api
545		keep_na_srv = function(id) {
546	!	moduleServer(id, function(input, output, session) {
547		# this observer is needed in the situation when private$keep_inf has been
548		# changed directly by the api - then it's needed to rerender UI element
549		# to show relevant values
550	!	private$observers$keep_na_api <- observeEvent(
551	!	ignoreNULL = FALSE, # nothing selected is possible for NA
552	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
553	!	eventExpr = self$get_keep_na(),
554	!	handlerExpr = {
555	!	if (!setequal(self$get_keep_na(), input$value)) {
556	!	updateCheckboxInput(
557	!	inputId = "value",
558	!	value = self$get_keep_na()
559		)
560		}
561		}
562		)
563	!	private$observers$keep_na <- observeEvent(
564	!	ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput`
565	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
566	!	eventExpr = input$value,
567	!	handlerExpr = {
568	!	keep_na <- if (is.null(input$value)) {
569	!	FALSE
570		} else {
571	!	input$value
572		}
573	!	self$set_keep_na(keep_na)
574	!	logger::log_trace(
575	!	sprintf(
576	!	"%s$server keep_na of variable %s set to: %s, dataname: %s",
577	!	class(self)[1],
578	!	private$varname,
579	!	deparse1(input$value),
580	!	private$dataname
581		)
582		)
583		}
584		)
585	!	invisible(NULL)
586		})
587		}
588		)
589		)

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

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

1		# DefaultFilteredDataset ------
2		#' @title The `DefaultFilteredDataset` R6 class
3		#' @keywords internal
4		#' @examples
5		#' library(shiny)
6		#' ds <- teal.slice:::DefaultFilteredDataset$new(iris, "iris")
7		#' isolate(
8		#' ds$set_filter_state(
9		#' state = list(
10		#' Species = list(selected = "virginica"),
11		#' Petal.Length = list(selected = c(2.0, 5))
12		#' )
13		#' )
14		#' )
15		#' isolate(ds$get_filter_state())
16		#' isolate(ds$get_call())
17		DefaultFilteredDataset <- R6::R6Class( # nolint
18		classname = "DefaultFilteredDataset",
19		inherit = FilteredDataset,
20		public = list(
21
22		#' @description
23		#' Initializes this `DefaultFilteredDataset` object
24		#'
25		#' @param dataset (`data.frame`)\cr
26		#' single data.frame for which filters are rendered
27		#' @param dataname (`character`)\cr
28		#' A given name for the dataset it may not contain spaces
29		#' @param keys optional, (`character`)\cr
30		#' Vector with primary keys
31		#' @param label (`character`)\cr
32		#' Label to describe the dataset
33		#' @param metadata (named `list` or `NULL`) \cr
34		#' Field containing metadata about the dataset. Each element of the list
35		#' should be atomic and length one.
36		initialize = function(dataset, dataname, keys = character(0), label = character(0), metadata = NULL) {
37	109x	checkmate::assert_class(dataset, "data.frame")
38	109x	super$initialize(dataset, dataname, keys, label, metadata)
39	109x	dataname <- self$get_dataname()
40
41	109x	private$add_filter_states(
42	109x	filter_states = init_filter_states(
43	109x	data = self$get_dataset(),
44	109x	dataname = dataname,
45	109x	varlabels = self$get_varlabels(),
46	109x	keys = self$get_keys()
47		),
48	109x	id = "filter"
49		)
50	109x	invisible(self)
51		},
52
53		#' @description
54		#' Gets the filter expression
55		#'
56		#' This functions returns filter calls equivalent to selected items
57		#' within each of `filter_states`. Configuration of the calls is constant and
58		#' depends on `filter_states` type and order which are set during initialization.
59		#' This class contains single `FilterStates`
60		#' which contains single `state_list` and all `FilterState` objects
61		#' applies to one argument (`...`) in `dplyr::filter` call.
62		#' @return filter `call` or `list` of filter calls
63		get_call = function() {
64	26x	filter_call <- Filter(
65	26x	f = Negate(is.null),
66	26x	x = lapply(
67	26x	self$get_filter_states(),
68	26x	function(x) x$get_call()
69		)
70		)
71	26x	if (length(filter_call) == 0) {
72	17x	return(NULL)
73		}
74	9x	filter_call
75		},
76
77		#' @description
78		#' Gets the reactive values from the active `FilterState` objects.
79		#'
80		#' Get all active filters from this dataset in form of the nested list.
81		#' The output list is a compatible input to `self$set_filter_state`.
82		#' @return `list` with named elements corresponding to `FilterState` objects
83		#' (active filters).
84		get_filter_state = function() {
85	36x	self$get_filter_states("filter")$get_filter_state()
86		},
87
88		#' @description
89		#' Set filter state
90		#'
91		#' @param state (`named list`)\cr
92		#' containing values of the initial filter. Values should be relevant
93		#' to the referred column.
94		#' @param ... Additional arguments. Note that this is currently not used
95		#' @examples
96		#' dataset <- teal.slice:::DefaultFilteredDataset$new(iris, "iris")
97		#' fs <- list(
98		#' Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE),
99		#' Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE)
100		#' )
101		#' shiny::isolate(dataset$set_filter_state(state = fs))
102		#' shiny::isolate(dataset$get_filter_state())
103		#'
104		#' @return `NULL`
105		set_filter_state = function(state, ...) {
106	40x	checkmate::assert_list(state)
107	40x	logger::log_trace(
108	40x	sprintf(
109	40x	"DefaultFilteredDataset$set_filter_state setting up filters of variables %s, dataname: %s",
110	40x	paste(names(state), collapse = ", "),
111	40x	self$get_dataname()
112		)
113		)
114
115	40x	data <- self$get_dataset()
116	40x	fs <- self$get_filter_states()[[1]]
117	40x	fs$set_filter_state(state = state, data = data, ...)
118	38x	logger::log_trace(
119	38x	sprintf(
120	38x	"DefaultFilteredDataset$set_filter_state done setting up filters of variables %s, dataname: %s",
121	38x	paste(names(state), collapse = ", "),
122	38x	self$get_dataname()
123		)
124		)
125	38x	NULL
126		},
127
128		#' @description Remove one or more `FilterState` of a `FilteredDataset`
129		#'
130		#' @param state_id (`character`)\cr
131		#' Vector of character names of variables to remove their `FilterState`.
132		#'
133		#' @return `NULL`
134		remove_filter_state = function(state_id) {
135	5x	logger::log_trace(
136	5x	sprintf(
137	5x	"DefaultFilteredDataset$remove_filter_state removing filters of variable %s, dataname: %s",
138	5x	state_id,
139	5x	self$get_dataname()
140		)
141		)
142
143	5x	fdata_filter_state <- self$get_filter_states()[[1]]
144	5x	for (element in state_id) {
145	7x	fdata_filter_state$remove_filter_state(element)
146		}
147	5x	logger::log_trace(
148	5x	sprintf(
149	5x	"DefaultFilteredDataset$remove_filter_state done removing filters of variable %s, dataname: %s",
150	5x	state_id,
151	5x	self$get_dataname()
152		)
153		)
154	5x	invisible(NULL)
155		},
156
157		#' @description
158		#' UI module to add filter variable for this dataset
159		#'
160		#' UI module to add filter variable for this dataset
161		#' @param id (`character(1)`)\cr
162		#' identifier of the element - preferably containing dataset name
163		#'
164		#' @return function - shiny UI module
165		ui_add_filter_state = function(id) {
166	!	ns <- NS(id)
167	!	tagList(
168	!	tags$label("Add", tags$code(self$get_dataname()), "filter"),
169	!	self$get_filter_states(id = "filter")$ui_add_filter_state(
170	!	id = ns("filter"),
171	!	data = self$get_dataset()
172		)
173		)
174		},
175
176		#' @description
177		#' Server module to add filter variable for this dataset
178		#'
179		#' Server module to add filter variable for this dataset.
180		#' For this class `srv_add_filter_state` calls single module
181		#' `srv_add_filter_state` from `FilterStates` (`DefaultFilteredDataset`
182		#' contains single `FilterStates`)
183		#'
184		#' @param id (`character(1)`)\cr
185		#' an ID string that corresponds with the ID used to call the module's UI function.
186		#' @param ... other arguments passed on to child `FilterStates` methods.
187		#'
188		#' @return `moduleServer` function which returns `NULL`
189		srv_add_filter_state = function(id, ...) {
190	8x	check_ellipsis(..., stop = FALSE, allowed_args = "vars_include")
191	8x	moduleServer(
192	8x	id = id,
193	8x	function(input, output, session) {
194	8x	logger::log_trace(
195	8x	"DefaultFilteredDataset$srv_add_filter_state initializing, dataname: { deparse1(self$get_dataname()) }"
196		)
197	8x	data <- self$get_dataset()
198	8x	self$get_filter_states(id = "filter")$srv_add_filter_state(
199	8x	id = "filter",
200	8x	data = data,
201		...
202		)
203	8x	logger::log_trace(
204	8x	"DefaultFilteredDataset$srv_add_filter_state initialized, dataname: { deparse1(self$get_dataname()) }"
205		)
206	8x	NULL
207		}
208		)
209		},
210
211		#' @description
212		#' Get number of observations based on given keys
213		#' The output shows the comparison between `filtered_dataset`
214		#' function parameter and the dataset inside self
215		#' @param filtered_dataset comparison object, of the same class
216		#' as `self$get_dataset()`, if `NULL` then `self$get_dataset()`
217		#' is used.
218		#' @param subject_keys (`character` or `NULL`) columns denoting unique subjects when
219		#' calculating the filtering.
220		#' @return `list` containing character `#filtered/#not_filtered`
221		get_filter_overview_nsubjs = function(filtered_dataset = self$get_dataset(), subject_keys = NULL) {
222	8x	checkmate::assert_class(filtered_dataset, classes = class(self$get_dataset()))
223	8x	checkmate::assert_character(subject_keys, null.ok = TRUE, any.missing = FALSE)
224
225	8x	f_rows <- if (length(subject_keys) == 0) {
226	4x	dplyr::n_distinct(filtered_dataset)
227		} else {
228	4x	dplyr::n_distinct(filtered_dataset[subject_keys])
229		}
230
231	8x	nf_rows <- if (length(subject_keys) == 0) {
232	4x	dplyr::n_distinct(self$get_dataset())
233		} else {
234	4x	dplyr::n_distinct(self$get_dataset()[subject_keys])
235		}
236
237	8x	list(paste0(f_rows, "/", nf_rows))
238		}
239		),
240		private = list(
241		# Gets filter overview observations number and returns a
242		# list of the number of observations of filtered/non-filtered datasets
243		get_filter_overview_nobs = function(filtered_dataset) {
244	10x	f_rows <- nrow(filtered_dataset)
245	10x	nf_rows <- nrow(self$get_dataset())
246	10x	list(
247	10x	paste0(f_rows, "/", nf_rows)
248		)
249		}
250		)
251		)

1		#' Initializes `FilteredDataset`
2		#'
3		#' @keywords internal
4		#' @examples
5		#' # DefaultFilteredDataset example
6		#' iris_fd <- teal.slice:::init_filtered_dataset(
7		#' iris,
8		#' dataname = "iris",
9		#' metadata = list(type = "teal")
10		#' )
11		#' \dontrun{
12		#' shinyApp(
13		#' ui = fluidPage(
14		#' iris_fd$ui_add_filter_state(id = "add"),
15		#' iris_fd$ui("dataset"),
16		#' verbatimTextOutput("call"),
17		#' verbatimTextOutput("metadata")
18		#' ),
19		#' server = function(input, output, session) {
20		#' iris_fd$srv_add_filter_state(id = "add")
21		#' iris_fd$server(id = "dataset")
22		#'
23		#' output$metadata <- renderText({
24		#' paste("Type =", iris_fd$get_metadata()$type)
25		#' })
26		#'
27		#' output$call <- renderText({
28		#' paste(
29		#' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),
30		#' collapse = "\n"
31		#' )
32		#' })
33		#' }
34		#' )
35		#' }
36		#'
37		#' # MAEFilteredDataset example
38		#' library(MultiAssayExperiment)
39		#' data(miniACC)
40		#' MAE_fd <- teal.slice:::init_filtered_dataset(miniACC, "MAE", metadata = list(type = "MAE"))
41		#' \dontrun{
42		#' shinyApp(
43		#' ui = fluidPage(
44		#' MAE_fd$ui_add_filter_state(id = "add"),
45		#' MAE_fd$ui("dataset"),
46		#' verbatimTextOutput("call"),
47		#' verbatimTextOutput("metadata")
48		#' ),
49		#' server = function(input, output, session) {
50		#' MAE_fd$srv_add_filter_state(id = "add")
51		#' MAE_fd$server(id = "dataset")
52		#' output$metadata <- renderText({
53		#' paste("Type =", MAE_fd$get_metadata()$type)
54		#' })
55		#' output$call <- renderText({
56		#' paste(
57		#' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),
58		#' collapse = "\n"
59		#' )
60		#' })
61		#' }
62		#' )
63		#' }
64		#' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr
65		#' @param dataname (`character`)\cr
66		#' A given name for the dataset it may not contain spaces
67		#' @param keys optional, (`character`)\cr
68		#' Vector with primary keys
69		#' @param label (`character`)\cr
70		#' Label to describe the dataset
71		#' @param metadata (named `list` or `NULL`) \cr
72		#' Field containing metadata about the dataset. Each element of the list
73		#' should be atomic and length one.
74		#' @export
75		#' @note Although this function is exported for use in other packages, it may be changed or removed in a future release
76		#' at which point any code which relies on this exported function will need to be changed.
77		init_filtered_dataset <- function(dataset, # nolint
78		dataname,
79		keys = character(0),
80		label = attr(dataset, "label"),
81		metadata = NULL) {
82	109x	UseMethod("init_filtered_dataset")
83		}
84
85		#' @keywords internal
86		#' @export
87		init_filtered_dataset.data.frame <- function(dataset, # nolint
88		dataname,
89		keys = character(0),
90		label = attr(dataset, "label"),
91		metadata = NULL) {
92	98x	DefaultFilteredDataset$new(dataset, dataname, keys, label, metadata)
93		}
94
95		#' @keywords internal
96		#' @export
97		init_filtered_dataset.MultiAssayExperiment <- function(dataset, # nolint
98		dataname,
99		keys = character(0),
100		label = attr(dataset, "label"),
101		metadata = NULL) {
102	11x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
103	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
104		}
105	11x	MAEFilteredDataset$new(dataset, dataname, keys, label, metadata)
106		}
107
108		# FilteredDataset abstract --------
109		#' @title `FilterStates` R6 class
110		#' @description
111		#' `FilteredDataset` is a class which renders/controls `FilterStates`(s)
112		#' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one
113		#' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects.
114		#' Each `FilterStates` is responsible for one filter/subset expression applied for specific
115		#' components of the dataset.
116		#' @keywords internal
117		FilteredDataset <- R6::R6Class( # nolint
118		"FilteredDataset",
119		## __Public Methods ====
120		public = list(
121		#' @description
122		#' Initializes this `FilteredDataset` object
123		#'
124		#' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr
125		#' single dataset for which filters are rendered
126		#' @param dataname (`character(1)`)\cr
127		#' A given name for the dataset it may not contain spaces
128		#' @param keys optional, (`character`)\cr
129		#' Vector with primary keys
130		#' @param label (`character(1)`)\cr
131		#' Label to describe the dataset
132		#' @param metadata (named `list` or `NULL`) \cr
133		#' Field containing metadata about the dataset. Each element of the list
134		#' should be atomic and length one.
135		initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label"), metadata = NULL) {
136		# dataset assertion in child classes
137
138	153x	check_simple_name(dataname)
139	153x	checkmate::assert_character(keys, any.missing = FALSE)
140	153x	checkmate::assert_character(label, null.ok = TRUE)
141	153x	teal.data::validate_metadata(metadata)
142
143	153x	logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
144	153x	private$dataset <- dataset
145	153x	private$dataname <- dataname
146	153x	private$keys <- keys
147	153x	private$label <- if (is.null(label)) character(0) else label
148	153x	private$metadata <- metadata
149	153x	invisible(self)
150		},
151
152
153		#' @description
154		#' Returns a string representation of the filter state in this `FilteredDataset`.
155		#'
156		#' @return `character(1)` the formatted string representing the filter state or
157		#' `NULL` if no filter state is present.
158		#'
159		get_formatted_filter_state = function() {
160	46x	out <- Filter(
161	46x	function(x) x != "",
162	46x	sapply(
163	46x	self$get_filter_states(),
164	46x	function(states) {
165	66x	states$format(indent = 2)
166		}
167		)
168		)
169	46x	if (length(out) > 0) {
170	25x	header <- paste0("Filters for dataset: ", self$get_dataname())
171	25x	paste(c(header, out), collapse = "\n")
172		}
173		},
174
175		#' @description
176		#' Removes all active filter items applied to this dataset
177		#' @return NULL
178		state_lists_empty = function() {
179	14x	logger::log_trace("Removing all filters from FilteredDataset: { deparse1(self$get_dataname()) }")
180	14x	lapply(
181	14x	self$get_filter_states(),
182	14x	function(state_list) state_list$state_list_empty()
183		)
184	14x	logger::log_trace("Removed all filters from FilteredDataset: { deparse1(self$get_dataname()) }")
185	14x	NULL
186		},
187		# managing filter states -----
188
189
190		# getters ----
191		#' @description
192		#' Gets a filter expression
193		#'
194		#' This functions returns filter calls equivalent to selected items
195		#' within each of `filter_states`. Configuration of the calls is constant and
196		#' depends on `filter_states` type and order which are set during initialization.
197		#' @return filter `call` or `list` of filter calls
198		get_call = function() {
199	!	stop("Pure virtual method.")
200		},
201
202		#' Gets the reactive values from the active `FilterState` objects.
203		#'
204		#' Get all active filters from this dataset in form of the nested list.
205		#' The output list is a compatible input to `self$set_filter_state`.
206		#' @return `list` with named elements corresponding to `FilterStates` objects
207		#' with active filters.
208		get_filter_state = function() {
209	9x	states <- lapply(self$get_filter_states(), function(x) x$get_filter_state())
210	9x	Filter(function(x) length(x) > 0, states)
211		},
212
213		#' @description
214		#' Gets the active `FilterStates` objects.
215		#' @param id (`character(1)`, `character(0)`)\cr
216		#' the id of the `private$filter_states` list element where `FilterStates` is kept.
217		#' @return `FilterStates` or `list` of `FilterStates` objects.
218		get_filter_states = function(id = character(0)) {
219	526x	if (length(id) == 0) {
220	463x	private$filter_states
221		} else {
222	63x	private$filter_states[[id]]
223		}
224		},
225
226		#' @description
227		#' Gets the number of active `FilterState` objects in all `FilterStates` in this `FilteredDataset`.
228		#' @return `integer(1)`
229		get_filter_count = function() {
230	12x	sum(vapply(private$filter_states,
231	12x	function(state) state$get_filter_count(),
232	12x	FUN.VALUE = integer(1)
233		))
234		},
235
236		#' @description
237		#' Get name of the dataset
238		#'
239		#' Get name of the dataset
240		#' @return `character(1)` as a name of this dataset
241		get_dataname = function() {
242	160x	private$dataname
243		},
244
245		#' @description
246		#' Gets the dataset object in this `FilteredDataset`
247		#' @return `data.frame` or `MultiAssayExperiment`
248		get_dataset = function() {
249	301x	private$dataset
250		},
251
252		#' @description
253		#' Gets the metadata for the dataset in this `FilteredDataset`
254		#' @return named `list` or `NULL`
255		get_metadata = function() {
256	4x	private$metadata
257		},
258
259		#' @description
260		#' Get filter overview rows of a dataset
261		#' The output shows the comparison between `filtered_dataset`
262		#' function parameter and the dataset inside self
263		#' @param filtered_dataset comparison object, of the same class
264		#' as `self$get_dataset()`, if `NULL` then `self$get_dataset()`
265		#' is used.
266		#' @return (`matrix`) matrix of observations and subjects
267		get_filter_overview_info = function(filtered_dataset = self$get_dataset()) {
268	10x	checkmate::assert_class(filtered_dataset, classes = class(self$get_dataset()))
269	10x	df <- cbind(private$get_filter_overview_nobs(filtered_dataset), "")
270	10x	rownames(df) <- self$get_dataname()
271	10x	colnames(df) <- c("Obs", "Subjects")
272	10x	df
273		},
274
275		#' @description
276		#' Gets the keys for the dataset of this `FilteredDataset`
277		#' @return (`character`) the keys of dataset
278		get_keys = function() {
279	151x	private$keys
280		},
281
282		#' @description
283		#' Gets labels of variables in the data
284		#'
285		#' Variables are the column names of the data.
286		#' Either, all labels must have been provided for all variables
287		#' in `set_data` or `NULL`.
288		#'
289		#' @param variables (`character` vector) variables to get labels for;
290		#' if `NULL`, for all variables in data
291		#' @return (`character` or `NULL`) variable labels, `NULL` if `column_labels`
292		#' attribute does not exist for the data
293		get_varlabels = function(variables = NULL) {
294	115x	checkmate::assert_character(variables, null.ok = TRUE, any.missing = FALSE)
295
296	115x	labels <- formatters::var_labels(private$dataset, fill = FALSE)
297	115x	if (is.null(labels)) {
298	!	return(NULL)
299		}
300	2x	if (!is.null(variables)) labels <- labels[intersect(self$get_varnames(), variables)]
301	115x	labels
302		},
303
304		#' @description
305		#' Gets the dataset label
306		#' @return (`character`) the dataset label
307		get_dataset_label = function() {
308	3x	private$label
309		},
310
311		#' @description
312		#' Gets variable names from dataset
313		#' @return `character` the variable names
314		get_varnames = function() {
315	4x	colnames(self$get_dataset())
316		},
317
318		#' @description
319		#' Gets variable names for the filtering.
320		#'
321		#' It takes the intersection of the column names
322		#' of the data and `private$filterable_varnames` if
323		#' `private$filterable_varnames` has positive length
324		#'
325		#' @return (`character` vector) of variable names
326		get_filterable_varnames = function() {
327	49x	varnames <- get_supported_filter_varnames(self)
328	49x	if (length(private$filterable_varnames) > 0) {
329	4x	return(intersect(private$filterable_varnames, varnames))
330		}
331	45x	return(varnames)
332		},
333
334		# setters ------
335		#' @description
336		#' Set the allowed filterable variables
337		#' @param varnames (`character` or `NULL`) The variables which can be filtered
338		#' See `self$get_filterable_varnames` for more details
339		#'
340		#' @details When retrieving the filtered variables only
341		#' those which have filtering supported (i.e. are of the permitted types)
342		#' are included.
343		#'
344		#' @return invisibly this `FilteredDataset`
345		set_filterable_varnames = function(varnames) {
346	10x	checkmate::assert_character(varnames, any.missing = FALSE, null.ok = TRUE)
347	7x	private$filterable_varnames <- varnames
348	7x	return(invisible(self))
349		},
350
351		# modules ------
352		#' @description
353		#' UI module for dataset active filters
354		#'
355		#' UI module containing dataset active filters along with
356		#' title and remove button.
357		#' @param id (`character(1)`)\cr
358		#' identifier of the element - preferably containing dataset name
359		#'
360		#' @return function - shiny UI module
361		ui = function(id) {
362	!	dataname <- self$get_dataname()
363	!	checkmate::assert_string(dataname)
364
365	!	ns <- NS(id)
366	!	if_multiple_filter_states <- length(self$get_filter_states()) > 1
367	!	span(
368	!	id = id,
369	!	include_css_files("filter-panel"),
370	!	div(
371	!	id = ns("whole_ui"), # to hide it entirely
372	!	fluidRow(
373	!	column(
374	!	width = 8,
375	!	tags$span(dataname, class = "filter_panel_dataname")
376		),
377	!	column(
378	!	width = 4,
379	!	tagList(
380	!	actionLink(
381	!	ns("remove_filters"),
382	!	label = "",
383	!	icon = icon("circle-xmark", lib = "font-awesome"),
384	!	class = "remove pull-right"
385		),
386	!	actionLink(
387	!	ns("collapse"),
388	!	label = "",
389	!	icon = icon("angle-down", lib = "font-awesome"),
390	!	class = "remove pull-right"
391		)
392		)
393		)
394		),
395	!	shinyjs::hidden(
396	!	div(
397	!	id = ns("filter_count_ui"),
398	!	tagList(
399	!	textOutput(ns("filter_count")),
400	!	br()
401		)
402		)
403		),
404	!	div(
405		# id needed to insert and remove UI to filter single variable as needed
406		# it is currently also used by the above module to entirely hide this panel
407	!	id = ns("filters"),
408	!	class = "parent-hideable-list-group",
409	!	tagList(
410	!	lapply(
411	!	names(self$get_filter_states()),
412	!	function(x) {
413	!	tagList(self$get_filter_states(id = x)$ui(id = ns(x)))
414		}
415		)
416		)
417		)
418		)
419		)
420		},
421
422		#' @description
423		#' Server module for a dataset active filters
424		#'
425		#' Server module managing a active filters.
426		#' @param id (`character(1)`)\cr
427		#' an ID string that corresponds with the ID used to call the module's UI function.
428		#' @return `moduleServer` function which returns `NULL`
429		server = function(id) {
430	9x	moduleServer(
431	9x	id = id,
432	9x	function(input, output, session) {
433	9x	dataname <- self$get_dataname()
434	9x	logger::log_trace("FilteredDataset$server initializing, dataname: { dataname }")
435	9x	checkmate::assert_string(dataname)
436	9x	shiny::setBookmarkExclude("remove_filters")
437
438	9x	output$filter_count <- renderText(
439	9x	sprintf(
440	9x	"%d filter%s applied",
441	9x	self$get_filter_count(),
442	9x	if (self$get_filter_count() != 1) "s" else ""
443		)
444		)
445
446	9x	lapply(
447	9x	names(self$get_filter_states()),
448	9x	function(x) {
449	14x	self$get_filter_states(id = x)$server(id = x)
450		}
451		)
452
453	9x	shiny::observeEvent(self$get_filter_state(), {
454	2x	shinyjs::hide("filter_count_ui")
455	2x	shinyjs::show("filters")
456	2x	shinyjs::toggle("remove_filters", condition = length(self$get_filter_state()) != 0)
457	2x	shinyjs::toggle("collapse", condition = length(self$get_filter_state()) != 0)
458		})
459
460	9x	shiny::observeEvent(input$collapse, {
461	!	shinyjs::toggle("filter_count_ui")
462	!	shinyjs::toggle("filters")
463	!	toggle_icon(session$ns("collapse"), c("fa-angle-right", "fa-angle-down"))
464		})
465
466	9x	observeEvent(input$remove_filters, {
467	1x	logger::log_trace("FilteredDataset$server@1 removing filters, dataname: { dataname }")
468	1x	lapply(
469	1x	self$get_filter_states(),
470	1x	function(x) x$state_list_empty()
471		)
472	1x	logger::log_trace("FilteredDataset$server@1 removed filters, dataname: { dataname }")
473		})
474
475	9x	logger::log_trace("FilteredDataset$initialized, dataname: { dataname }")
476	9x	NULL
477		}
478		)
479		},
480
481		#' @description
482		#' UI module to add filter variable for this dataset
483		#'
484		#' UI module to add filter variable for this dataset
485		#' @param id (`character(1)`)\cr
486		#' identifier of the element - preferably containing dataset name
487		#'
488		#' @return function - shiny UI module
489		ui_add_filter_state = function(id) {
490	1x	stop("Pure virtual method")
491		},
492
493		#' @description
494		#' Server module to add filter variable for this dataset
495		#'
496		#' Server module to add filter variable for this dataset
497		#' @param id (`character(1)`)\cr
498		#' an ID string that corresponds with the ID used to call the module's UI function.
499		#' @param ... ignored
500		#' @return `moduleServer` function.
501		srv_add_filter_state = function(id, ...) {
502	!	check_ellipsis(..., stop = FALSE)
503	!	moduleServer(
504	!	id = id,
505	!	function(input, output, session) {
506	!	stop("Pure virtual method")
507		}
508		)
509		}
510		),
511		## __Private Fields ====
512		private = list(
513		dataset = NULL,
514		filter_states = list(),
515		dataname = character(0),
516		keys = character(0),
517		label = character(0),
518		metadata = NULL,
519
520		# if this has length > 0 then only varnames in this vector
521		# can be filtered
522		filterable_varnames = NULL,
523
524		# Adds `FilterStates` to the `private$filter_states`.
525		# `FilterStates` is added once for each element of the dataset.
526		# @param filter_states (`FilterStates`)
527		# @param id (`character(1)`)
528		add_filter_states = function(filter_states, id) {
529	271x	stopifnot(is(filter_states, "FilterStates"))
530	271x	checkmate::assert_string(id)
531
532	271x	x <- setNames(list(filter_states), id)
533	271x	private$filter_states <- c(self$get_filter_states(), x)
534		},
535
536		# @description
537		# Checks if the dataname exists and
538		# (if provided) that varname is a valid column in the dataset
539		#
540		# Stops when this is not the case.
541		#
542		# @param varname (`character`) column within the dataset;
543		# if `NULL`, this check is not performed
544		check_data_varname_exists = function(varname = NULL) {
545	!	checkmate::assert_string(varname, null.ok = TRUE)
546
547	!	isolate({
548	!	if (!is.null(varname) && !(varname %in% self$get_varnames())) {
549	!	stop(
550	!	sprintf("variable '%s' does not exist in data '%s'", varname, dataname)
551		)
552		}
553		})
554
555	!	return(invisible(NULL))
556		}
557		)
558		)

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

1		#' @title `FilterStates` subclass for data frames
2		#' @description Handles filter states in a `data.frame`
3		#' @keywords internal
4		#'
5		#'
6		#' @examples
7		#' \dontrun{
8		#' # working filters in an app
9		#'
10		#' library(shiny)
11		#'
12		#' # create data frame to filter
13		#' data_df <- data.frame(
14		#' NUM1 = 1:100,
15		#' NUM2 = round(runif(100, min = 20, max = 23)),
16		#' CHAR1 = sample(LETTERS[1:6], size = 100, replace = TRUE),
17		#' CHAR2 = sample(c("M", "F"), size = 100, replace = TRUE),
18		#' DATE = seq(as.Date("2020-01-01"), by = 1, length.out = 100),
19		#' DATETIME = as.POSIXct(seq(as.Date("2020-01-01"), by = 1, length.out = 100))
20		#' )
21		#' data_na <- data.frame(
22		#' NUM1 = NA,
23		#' NUM2 = NA,
24		#' CHAR1 = NA,
25		#' CHAR2 = NA,
26		#' DATE = NA,
27		#' DATETIME = NA
28		#' )
29		#' data_df <- rbind(data_df, data_na)
30		#'
31		#'
32		#' # initiate FilterStates object
33		#' filter_states_df <- init_filter_states(
34		#' data = data_df,
35		#' dataname = "dataset",
36		#' datalabel = ("label"),
37		#' varlabels = c("long", "short", "long", "short", "long", "long")
38		#' )
39		#'
40		#' ui <- fluidPage(
41		#' column(4, div(
42		#' h4("Active filters"),
43		#' filter_states_df$ui("fsdf")
44		#' )),
45		#' column(4, div(
46		#' h4("Manual filter control"),
47		#' filter_states_df$ui_add_filter_state("add_filters", data_df), br(),
48		#' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterStates
49		#' textOutput("call_df"), br(),
50		#' h4("Formatted state"), # display human readable filter state
51		#' textOutput("formatted_df"), br()
52		#' )),
53		#' column(4, div(
54		#' h4("Programmatic filter control"),
55		#' actionButton("button1_df", "set NUM1 < 30", width = "100%"), br(),
56		#' actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), br(),
57		#' actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"), br(),
58		#' actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), br(),
59		#' actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), br(),
60		#' actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), br(),
61		#' hr(),
62		#' actionButton("button7_df", "remove NUM1", width = "100%"), br(),
63		#' actionButton("button8_df", "remove NUM2", width = "100%"), br(),
64		#' actionButton("button9_df", "remove CHAR1", width = "100%"), br(),
65		#' actionButton("button10_df", "remove CHAR2", width = "100%"), br(),
66		#' actionButton("button11_df", "remove DATE", width = "100%"), br(),
67		#' actionButton("button12_df", "remove DATETIME", width = "100%"), br(),
68		#' hr(),
69		#' actionButton("button0_df", "clear all filters", width = "100%"), br()
70		#' ))
71		#' )
72		#'
73		#' server <- function(input, output, session) {
74		#' filter_states_df$srv_add_filter_state("add_filters", data_df)
75		#' filter_states_df$server("fsdf")
76		#'
77		#' output$call_df <- renderPrint(filter_states_df$get_call())
78		#' output$formatted_df <- renderText(filter_states_df$format())
79		#'
80		#' observeEvent(input$button1_df, {
81		#' filter_state <- list(NUM1 = list(selected = c(0, 30)))
82		#' filter_states_df$set_filter_state(data = data_df, state = filter_state)
83		#' })
84		#' observeEvent(input$button2_df, {
85		#' filter_state <- list(NUM2 = list(selected = c(20, 21)))
86		#' filter_states_df$set_filter_state(data = data_df, state = filter_state)
87		#' })
88		#' observeEvent(input$button3_df, {
89		#' filter_state <- list(CHAR1 = list(selected = c("B", "C", "D")))
90		#' filter_states_df$set_filter_state(data = data_df, state = filter_state)
91		#' })
92		#' observeEvent(input$button4_df, {
93		#' filter_state <- list(CHAR2 = list(selected = "F"))
94		#' filter_states_df$set_filter_state(data = data_df, state = filter_state)
95		#' })
96		#' observeEvent(input$button5_df, {
97		#' filter_state <- list(DATE = list(selected = c("2020-01-01", "2020-02-02")))
98		#' filter_states_df$set_filter_state(data = data_df, state = filter_state)
99		#' })
100		#' observeEvent(input$button6_df, {
101		#' filter_state <- list(DATETIME = list(selected = as.POSIXct(c("2020-01-01", "2020-02-02"))))
102		#' filter_states_df$set_filter_state(data = data_df, state = filter_state)
103		#' })
104		#' observeEvent(input$button7_df, filter_states_df$state_list_remove(1, state_id = "NUM1"))
105		#' observeEvent(input$button8_df, filter_states_df$state_list_remove(1, state_id = "NUM2"))
106		#' observeEvent(input$button9_df, filter_states_df$state_list_remove(1, state_id = "CHAR1"))
107		#' observeEvent(input$button10_df, filter_states_df$state_list_remove(1, state_id = "CHAR2"))
108		#' observeEvent(input$button11_df, filter_states_df$state_list_remove(1, state_id = "DATE"))
109		#' observeEvent(input$button12_df, filter_states_df$state_list_remove(1, state_id = "DATETIME"))
110		#' observeEvent(input$button0_df, filter_states_df$state_list_empty())
111		#' }
112		#'
113		#' if (interactive()) {
114		#' shinyApp(ui, server)
115		#' }
116		#' }
117		#'
118		DFFilterStates <- R6::R6Class( # nolint
119		classname = "DFFilterStates",
120		inherit = FilterStates,
121
122		# public methods ----
123		public = list(
124		#' @description Initializes `DFFilterStates` object.
125		#'
126		#' Initializes `DFFilterStates` object by setting `dataname`
127		#' and initializing `state_list` (`shiny::reactiveVal`).
128		#' This class contains a single `state_list` with no specified name,
129		#' which means that when calling the subset function associated with this class
130		#' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`).
131		#'
132		#' @param dataname (`character(1)`)\cr
133		#' name of the data used in the \emph{subset expression}
134		#' specified to the function argument attached to this `FilterStates`
135		#' @param datalabel (`character(0)` or `character(1)`)\cr
136		#' text label value
137		#' @param varlabels (`character`)\cr
138		#' labels of the variables used in this object
139		#' @param keys (`character`)\cr
140		#' key columns names
141		#'
142		initialize = function(dataname, datalabel, varlabels, keys) {
143	140x	super$initialize(dataname, datalabel)
144	140x	private$varlabels <- varlabels
145	140x	private$keys <- keys
146	140x	private$state_list <- list(
147	140x	reactiveVal()
148		)
149		},
150
151		#' @description
152		#' Returns a formatted string representing this `FilterStates` object.
153		#'
154		#' @param indent (`numeric(1)`) the number of spaces prepended to each line of the output
155		#'
156		#' @return `character(1)` the formatted string
157		#'
158		format = function(indent = 0) {
159	46x	checkmate::assert_number(indent, finite = TRUE, lower = 0)
160
161	45x	formatted_states <- vapply(
162	45x	self$state_list_get(1L), function(state) state$format(indent = indent),
163	45x	USE.NAMES = FALSE, FUN.VALUE = character(1)
164		)
165	45x	paste(formatted_states, collapse = "\n")
166		},
167
168		#' @description
169		#' Gets the name of the function used to filter the data in this `FilterStates`.
170		#'
171		#' Get name of function used to create the \emph{subset expression}.
172		#' For `DFFilterStates` this is `dplyr::filter`.
173		#'
174		#' @return `character(1)`
175		get_fun = function() {
176	26x	"dplyr::filter"
177		},
178
179		#' @description
180		#' Shiny server module.
181		#'
182		#' @param id (`character(1)`)\cr
183		#' shiny module instance id
184		#'
185		#' @return `moduleServer` function which returns `NULL`
186		#'
187		server = function(id) {
188	8x	moduleServer(
189	8x	id = id,
190	8x	function(input, output, session) {
191	8x	previous_state <- reactiveVal(isolate(self$state_list_get(1L)))
192	8x	added_state_name <- reactiveVal(character(0))
193	8x	removed_state_name <- reactiveVal(character(0))
194
195	8x	observeEvent(self$state_list_get(1L), {
196	!	added_state_name(setdiff(names(self$state_list_get(1L)), names(previous_state())))
197	!	removed_state_name(setdiff(names(previous_state()), names(self$state_list_get(1L))))
198	!	previous_state(self$state_list_get(1L))
199		})
200
201	8x	observeEvent(added_state_name(), ignoreNULL = TRUE, {
202	!	fstates <- self$state_list_get(1L)
203	!	html_ids <- private$map_vars_to_html_ids(names(fstates))
204	!	for (fname in added_state_name()) {
205	!	private$insert_filter_state_ui(
206	!	id = html_ids[fname],
207	!	filter_state = fstates[[fname]],
208	!	state_list_index = 1L,
209	!	state_id = fname
210		)
211		}
212	!	added_state_name(character(0))
213		})
214
215	8x	observeEvent(removed_state_name(), {
216	!	req(removed_state_name())
217	!	for (fname in removed_state_name()) {
218	!	private$remove_filter_state_ui(1L, fname, .input = input)
219		}
220	!	removed_state_name(character(0))
221		})
222	8x	NULL
223		}
224		)
225		},
226
227		#' @description
228		#' Gets the reactive values from the active `FilterState` objects.
229		#'
230		#' Get active filter state from the `FilterState` objects kept in `state_list`.
231		#' The output list is a compatible input to `self$set_filter_state`.
232		#'
233		#' @return `list` with named elements corresponding to `FilterState` in the `state_list`.
234		#'
235		get_filter_state = function() {
236	38x	lapply(self$state_list_get(1L), function(x) x$get_state())
237		},
238
239		#' @description
240		#' Set filter state.
241		#'
242		#' @param data (`data.frame`)\cr
243		#' data object for which to define a subset
244		#' @param state (`named list`)\cr
245		#' should contain values of initial selections in the `FilterState`;
246		#' `list` names must correspond to column names in `data`
247		#' @param vars_include (`character(n)`)\cr
248		#' optional, vector of column names to be included
249		#' @param ... ignored
250		#'
251		#' @examples
252		#' dffs <- teal.slice:::DFFilterStates$new(
253		#' dataname = "iris",
254		#' datalabel = character(0),
255		#' varlabels = character(0),
256		#' keys = character(0)
257		#' )
258		#' fs <- list(
259		#' Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE),
260		#' Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE)
261		#' )
262		#' shiny::isolate(dffs$set_filter_state(state = fs, data = iris))
263		#' shiny::isolate(dffs$get_filter_state())
264		#'
265		#' @return `NULL`
266		#'
267		set_filter_state = function(data, state, vars_include = get_supported_filter_varnames(data = data), ...) {
268	50x	checkmate::assert_data_frame(data)
269	50x	checkmate::assert(
270	50x	checkmate::check_subset(names(state), names(data)),
271	50x	checkmate::check_class(state, "default_filter"),
272	50x	combine = "or"
273		)
274	47x	logger::log_trace(
275	47x	"{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }"
276		)
277
278	47x	filter_states <- self$state_list_get(1L)
279	47x	state_names <- names(state)
280	47x	excluded_vars <- setdiff(state_names, vars_include)
281	47x	if (length(excluded_vars) > 0) {
282	1x	warning(
283	1x	paste(
284	1x	"These columns filters were excluded:",
285	1x	paste(excluded_vars, collapse = ", "),
286	1x	"from dataset",
287	1x	private$dataname
288		)
289		)
290	1x	logger::log_warn(
291	1x	paste(
292	1x	"Columns filters { paste(excluded_vars, collapse = ', ') } were excluded",
293	1x	"from { private$dataname }"
294		)
295		)
296		}
297
298	47x	filters_to_apply <- state_names[state_names %in% vars_include]
299
300	47x	for (varname in filters_to_apply) {
301	80x	value <- resolve_state(state[[varname]])
302	80x	if (varname %in% names(filter_states)) {
303	8x	fstate <- filter_states[[varname]]
304	8x	fstate$set_state(value)
305		} else {
306	72x	fstate <- init_filter_state(
307	72x	data[[varname]],
308	72x	varname = varname,
309	72x	varlabel = private$get_varlabels(varname),
310	72x	dataname = private$dataname
311		)
312	72x	fstate$set_state(value)
313	72x	self$state_list_push(x = fstate, state_list_index = 1L, state_id = varname)
314		}
315		}
316	47x	logger::log_trace(
317	47x	"{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }"
318		)
319	47x	NULL
320		},
321
322		#' @description Remove a `FilterState` from the `state_list`.
323		#'
324		#' @param state_id (`character(1)`)\cr name of `state_list` element
325		#'
326		#' @return `NULL`
327		#'
328		remove_filter_state = function(state_id) {
329	9x	logger::log_trace(
330	9x	sprintf(
331	9x	"%s$remove_filter_state for variable %s called, dataname: %s",
332	9x	class(self)[1],
333	9x	state_id,
334	9x	private$dataname
335		)
336		)
337
338	9x	if (!state_id %in% names(self$state_list_get(1L))) {
339	1x	warning(paste(
340	1x	"Variable:", state_id,
341	1x	"is not present in the actual active filters of dataset: { private$dataname }",
342	1x	"therefore no changes are applied."
343		))
344	1x	logger::log_warn(
345	1x	paste(
346	1x	"Variable:", state_id, "is not present in the actual active filters of dataset:",
347	1x	"{ private$dataname } therefore no changes are applied."
348		)
349		)
350		} else {
351	8x	self$state_list_remove(state_list_index = 1L, state_id = state_id)
352	8x	logger::log_trace(
353	8x	sprintf(
354	8x	"%s$remove_filter_state for variable %s done, dataname: %s",
355	8x	class(self)[1],
356	8x	state_id,
357	8x	private$dataname
358		)
359		)
360		}
361		},
362
363		# shiny modules ----
364
365		#' @description
366		#' Shiny UI module to add filter variable.
367		#'
368		#' @param id (`character(1)`)\cr
369		#' shiny element (module instance) id
370		#' @param data (`data.frame`)\cr
371		#' data object for which to define a subset
372		#'
373		#' @return `shiny.tag`
374		#'
375		ui_add_filter_state = function(id, data) {
376	2x	checkmate::assert_string(id)
377	2x	checkmate::assert_data_frame(data)
378
379	2x	ns <- NS(id)
380
381	2x	if (ncol(data) == 0) {
382	1x	div("no sample variables available")
383	1x	} else if (nrow(data) == 0) {
384	1x	div("no samples available")
385		} else {
386	!	div(
387	!	teal.widgets::optionalSelectInput(
388	!	ns("var_to_add"),
389	!	choices = NULL,
390	!	options = shinyWidgets::pickerOptions(
391	!	liveSearch = TRUE,
392	!	noneSelectedText = "Select variable to filter"
393		)
394		)
395		)
396		}
397		},
398
399		#' @description
400		#' Shiny server module to add filter variable.
401		#'
402		#' This module controls available choices to select as a filter variable.
403		#' Once selected, a variable is removed from available choices.
404		#' Removing a filter variable adds it back to available choices.
405		#'
406		#' @param id (`character(1)`)\cr
407		#' shiny module instance id
408		#' @param data (`data.frame`)\cr
409		#' data object for which to define a subset
410		#' @param vars_include (`character(n)`)\cr
411		#' optional, vector of column names to be included
412		#' @param ... ignored
413		#'
414		#' @return `moduleServer` function which returns `NULL`
415		#'
416		srv_add_filter_state = function(id, data, vars_include = get_supported_filter_varnames(data = data), ...) {
417	11x	stopifnot(is.data.frame(data))
418	11x	check_ellipsis(..., stop = FALSE)
419	11x	moduleServer(
420	11x	id = id,
421	11x	function(input, output, session) {
422	11x	logger::log_trace(
423	11x	"DFFilterStates$srv_add_filter_state initializing, dataname: { private$dataname }"
424		)
425	11x	shiny::setBookmarkExclude(c("var_to_add"))
426	11x	active_filter_vars <- reactive({
427	6x	vapply(
428	6x	X = self$state_list_get(state_list_index = 1L),
429	6x	FUN.VALUE = character(1),
430	6x	FUN = function(x) x$get_varname()
431		)
432		})
433
434		# available choices to display
435	11x	avail_column_choices <- reactive({
436	6x	choices <- setdiff(vars_include, active_filter_vars())
437
438	6x	data_choices_labeled(
439	6x	data = data,
440	6x	choices = choices,
441	6x	varlabels = private$get_varlabels(choices),
442	6x	keys = private$keys
443		)
444		})
445	11x	observeEvent(
446	11x	avail_column_choices(),
447	11x	ignoreNULL = TRUE,
448	11x	handlerExpr = {
449	6x	logger::log_trace(paste(
450	6x	"DFFilterStates$srv_add_filter_state@1 updating available column choices,",
451	6x	"dataname: { private$dataname }"
452		))
453	6x	if (is.null(avail_column_choices())) {
454	!	shinyjs::hide("var_to_add")
455		} else {
456	6x	shinyjs::show("var_to_add")
457		}
458	6x	teal.widgets::updateOptionalSelectInput(
459	6x	session,
460	6x	"var_to_add",
461	6x	choices = avail_column_choices()
462		)
463	6x	logger::log_trace(paste(
464	6x	"DFFilterStates$srv_add_filter_state@1 updated available column choices,",
465	6x	"dataname: { private$dataname }"
466		))
467		}
468		)
469
470	11x	observeEvent(
471	11x	eventExpr = input$var_to_add,
472	11x	handlerExpr = {
473	3x	logger::log_trace(
474	3x	sprintf(
475	3x	"DFFilterStates$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s",
476	3x	input$var_to_add,
477	3x	private$dataname
478		)
479		)
480	3x	self$state_list_push(
481	3x	x = init_filter_state(
482	3x	data[[input$var_to_add]],
483	3x	varname = input$var_to_add,
484	3x	varlabel = private$get_varlabels(input$var_to_add),
485	3x	dataname = private$dataname
486		),
487	3x	state_list_index = 1L,
488	3x	state_id = input$var_to_add
489		)
490	3x	logger::log_trace(
491	3x	sprintf(
492	3x	"DFFilterStates$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s",
493	3x	input$var_to_add,
494	3x	private$dataname
495		)
496		)
497		}
498		)
499
500	11x	logger::log_trace(
501	11x	"DFFilterStates$srv_add_filter_state initialized, dataname: { private$dataname }"
502		)
503	11x	NULL
504		}
505		)
506		}
507		),
508
509		# private members ----
510		private = list(
511		varlabels = character(0),
512		keys = character(0),
513		# @description
514		# Get label of specific variable. If variable label is missing, variable name is returned.
515		#
516		# @para variable (`character`)\cr
517		# name of variable for which label should be returned
518		#
519		# @return `character`
520		get_varlabels = function(variables = character(0)) {
521	81x	checkmate::assert_character(variables)
522	81x	if (identical(variables, character(0))) {
523	!	private$varlabels
524		} else {
525	81x	varlabels <- private$varlabels[variables]
526	81x	missing_labels <- is.na(varlabels) \| varlabels == ""
527	81x	varlabels[missing_labels] <- variables[missing_labels]
528	81x	varlabels
529		}
530		}
531		)
532		)

1		#' @title `FilterStates` subclass for matrices
2		#' @description Handles filter states in a `matrix`
3		#' @keywords internal
4		#'
5		#'
6		MatrixFilterStates <- R6::R6Class( # nolint
7		classname = "MatrixFilterStates",
8		inherit = FilterStates,
9
10		# public methods ----
11		public = list(
12		#' @description Initialize `MatrixFilterStates` object
13		#'
14		#' Initialize `MatrixFilterStates` object
15		#'
16		#' @param dataname (`character(1)`)\cr
17		#' name of the data used in the expression
18		#' specified to the function argument attached to this `FilterStates`.
19		#'
20		#' @param datalabel (`character(0)` or `character(1)`)\cr
21		#' text label value.
22		initialize = function(dataname, datalabel) {
23	45x	super$initialize(dataname, datalabel)
24	45x	private$state_list <- list(
25	45x	subset = reactiveVal()
26		)
27		},
28
29		#' @description
30		#' Returns the formatted string representing this `MatrixFilterStates` object.
31		#'
32		#' @param indent (`numeric(1)`) the number of spaces before each line of the representation
33		#' @return `character(1)` the formatted string
34		format = function(indent = 0) {
35	4x	checkmate::assert_number(indent, finite = TRUE, lower = 0)
36
37	4x	formatted_states <- c()
38	4x	for (state in self$state_list_get(state_list_index = "subset")) {
39	!	formatted_states <- c(formatted_states, state$format(indent = indent + 2))
40		}
41	4x	paste(formatted_states, collapse = "\n")
42		},
43
44		#' @description
45		#' Server module
46		#' @param id (`character(1)`)\cr
47		#' an ID string that corresponds with the ID used to call the module's UI function.
48		#' @return `moduleServer` function which returns `NULL`
49		server = function(id) {
50	1x	moduleServer(
51	1x	id = id,
52	1x	function(input, output, session) {
53	1x	previous_state <- reactiveVal(isolate(self$state_list_get("subset")))
54	1x	added_state_name <- reactiveVal(character(0))
55	1x	removed_state_name <- reactiveVal(character(0))
56
57	1x	observeEvent(self$state_list_get("subset"), {
58	1x	added_state_name(
59	1x	setdiff(names(self$state_list_get("subset")), names(previous_state()))
60		)
61	1x	removed_state_name(
62	1x	setdiff(names(previous_state()), names(self$state_list_get("subset")))
63		)
64	1x	previous_state(self$state_list_get("subset"))
65		})
66
67	1x	observeEvent(added_state_name(), ignoreNULL = TRUE, {
68	1x	fstates <- self$state_list_get("subset")
69	1x	html_ids <- private$map_vars_to_html_ids(keys = names(fstates))
70	1x	for (fname in added_state_name()) {
71	!	private$insert_filter_state_ui(
72	!	id = html_ids[fname],
73	!	filter_state = fstates[[fname]],
74	!	state_list_index = "subset",
75	!	state_id = fname
76		)
77		}
78	1x	added_state_name(character(0))
79		})
80
81	1x	observeEvent(removed_state_name(), {
82	1x	req(removed_state_name())
83
84	!	for (fname in removed_state_name()) {
85	!	private$remove_filter_state_ui("subset", fname, .input = input)
86		}
87	!	removed_state_name(character(0))
88		})
89	1x	NULL
90		}
91		)
92		},
93
94		#' @description
95		#' Returns active `FilterState` objects.
96		#'
97		#' Gets all active filters from this dataset in form of the nested list.
98		#' The output list can be used as input to `self$set_filter_state`.
99		#'
100		#' @return `list` containing `list` with selected values for each `FilterState`.
101		get_filter_state = function() {
102	9x	lapply(self$state_list_get(state_list_index = "subset"), function(x) x$get_state())
103		},
104
105		#' @description
106		#' Sets a filter state
107		#'
108		#' @param data (`matrix`)\cr
109		#' data which are supposed to be filtered.
110		#' @param state (`named list`)\cr
111		#' should contain values which are initial selection in the `FilterState`.
112		#' Names of the `list` element should correspond to the name of the
113		#' column in `data`.
114		#' @param ... ignored.
115		#' @return `NULL`
116		set_filter_state = function(data, state, ...) {
117	4x	checkmate::assert_class(data, "matrix")
118	4x	checkmate::assert(
119	4x	checkmate::assert(
120	4x	!checkmate::test_null(names(state)),
121	4x	checkmate::check_subset(names(state), colnames(data)),
122	4x	combine = "and"
123		),
124	4x	checkmate::check_class(state, "default_filter"),
125	4x	combine = "or"
126		)
127	3x	logger::log_trace(paste(
128	3x	"MatrixFilterState$set_filter_state initializing,",
129	3x	"dataname: { private$dataname }"
130		))
131	3x	filter_states <- self$state_list_get("subset")
132	3x	for (varname in names(state)) {
133	3x	value <- resolve_state(state[[varname]])
134	3x	if (varname %in% names(filter_states)) {
135	!	fstate <- filter_states[[varname]]
136	!	fstate$set_state(value)
137		} else {
138	3x	fstate <- init_filter_state(
139	3x	data[, varname],
140	3x	varname = varname,
141	3x	varlabel = varname,
142	3x	dataname = private$dataname,
143	3x	extract_type = "matrix"
144		)
145	3x	fstate$set_state(value)
146	3x	self$state_list_push(
147	3x	x = fstate,
148	3x	state_list_index = "subset",
149	3x	state_id = varname
150		)
151		}
152		}
153	3x	logger::log_trace(paste(
154	3x	"MatrixFilterState$set_filter_state initialized,",
155	3x	"dataname: { private$dataname }"
156		))
157	3x	NULL
158		},
159
160		#' @description Remove a variable from the `state_list` and its corresponding UI element.
161		#'
162		#' @param state_id (`character(1)`)\cr name of `state_list` element.
163		#'
164		#' @return `NULL`
165		remove_filter_state = function(state_id) {
166	2x	logger::log_trace(
167	2x	sprintf(
168	2x	"%s$remove_filter_state of variable %s, dataname: %s",
169	2x	class(self)[1],
170	2x	state_id,
171	2x	private$dataname
172		)
173		)
174
175	2x	if (!state_id %in% names(self$state_list_get("subset"))) {
176	1x	warning(paste(
177	1x	"Variable:", state_id, "is not present in the actual active filters of dataset:",
178	1x	"{ private$dataname } therefore no changes are applied."
179		))
180	1x	logger::log_warn(
181	1x	paste(
182	1x	"Variable:", state_id, "is not present in the actual active filters of dataset:",
183	1x	"{ private$dataname } therefore no changes are applied."
184		)
185		)
186		} else {
187	1x	self$state_list_remove(state_list_index = "subset", state_id = state_id)
188	1x	logger::log_trace(
189	1x	sprintf(
190	1x	"%s$remove_filter_state of variable %s done, dataname: %s",
191	1x	class(self)[1],
192	1x	state_id,
193	1x	private$dataname
194		)
195		)
196		}
197		},
198
199		# shiny modules ----
200
201		#' @description
202		#' Shiny UI module to add filter variable.
203		#'
204		#' @param id (`character(1)`)\cr
205		#' id of shiny module
206		#' @param data (`matrix`)\cr
207		#' data object for which to define a subset
208		#'
209		#' @return `shiny.tag`
210		#'
211		ui_add_filter_state = function(id, data) {
212	2x	checkmate::assert_string(id)
213	2x	stopifnot(is.matrix(data))
214
215	2x	ns <- NS(id)
216
217	2x	if (ncol(data) == 0) {
218	1x	div("no sample variables available")
219	1x	} else if (nrow(data) == 0) {
220	1x	div("no samples available")
221		} else {
222	!	teal.widgets::optionalSelectInput(
223	!	ns("var_to_add"),
224	!	choices = NULL,
225	!	options = shinyWidgets::pickerOptions(
226	!	liveSearch = TRUE,
227	!	noneSelectedText = "Select variable to filter"
228		)
229		)
230		}
231		},
232
233		#' @description
234		#' Shiny server module to add filter variable
235		#'
236		#' Module controls available choices to select as a filter variable.
237		#' Selected filter variable is being removed from available choices.
238		#' Removed filter variable gets back to available choices.
239		#'
240		#' @param id (`character(1)`)\cr
241		#' shiny module instance id
242		#' @param data (`matrix`)\cr
243		#' data object for which to define a subset
244		#' @param ... ignored
245		#'
246		#' @return `moduleServer` function which returns `NULL`
247		#'
248		srv_add_filter_state = function(id, data, ...) {
249	!	stopifnot(is.matrix(data))
250	!	check_ellipsis(..., stop = FALSE)
251	!	moduleServer(
252	!	id = id,
253	!	function(input, output, session) {
254	!	logger::log_trace(
255	!	"MatrixFilterStates$srv_add_filter_state initializing, dataname: { private$dataname }"
256		)
257	!	shiny::setBookmarkExclude("var_to_add")
258	!	active_filter_vars <- reactive({
259	!	vapply(
260	!	X = self$state_list_get(state_list_index = "subset"),
261	!	FUN.VALUE = character(1),
262	!	FUN = function(x) x$get_varname()
263		)
264		})
265
266		# available choices to display
267	!	avail_column_choices <- reactive({
268	!	choices <- setdiff(
269	!	get_supported_filter_varnames(data = data),
270	!	active_filter_vars()
271		)
272	!	data_choices_labeled(
273	!	data = data,
274	!	choices = choices,
275	!	varlabels = character(0),
276	!	keys = NULL
277		)
278		})
279	!	observeEvent(
280	!	avail_column_choices(),
281	!	ignoreNULL = TRUE,
282	!	handlerExpr = {
283	!	logger::log_trace(paste(
284	!	"MatrixFilterStates$srv_add_filter_state@1 updating column choices,",
285	!	"dataname: { private$dataname }"
286		))
287	!	if (length(avail_column_choices()) < 0) {
288	!	shinyjs::hide("var_to_add")
289		} else {
290	!	shinyjs::show("var_to_add")
291		}
292	!	teal.widgets::updateOptionalSelectInput(
293	!	session,
294	!	"var_to_add",
295	!	choices = avail_column_choices()
296		)
297	!	logger::log_trace(paste(
298	!	"MatrixFilterStates$srv_add_filter_state@1 updated column choices,",
299	!	"dataname: { private$dataname }"
300		))
301		}
302		)
303
304	!	observeEvent(
305	!	eventExpr = input$var_to_add,
306	!	handlerExpr = {
307	!	logger::log_trace(
308	!	sprintf(
309	!	"MatrixFilterState$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s",
310	!	deparse1(input$var_to_add),
311	!	private$dataname
312		)
313		)
314	!	self$state_list_push(
315	!	x = init_filter_state(
316	!	subset(data, select = input$var_to_add),
317	!	varname = input$var_to_add,
318	!	varlabel = private$get_varlabel(input$var_to_add),
319	!	dataname = private$dataname,
320	!	extract_type = "matrix"
321		),
322	!	state_list_index = "subset",
323	!	state_id = input$var_to_add
324		)
325	!	logger::log_trace(
326	!	sprintf(
327	!	"MatrixFilterState$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s",
328	!	deparse1(input$var_to_add),
329	!	private$dataname
330		)
331		)
332		}
333		)
334
335	!	logger::log_trace(
336	!	"MatrixFilterStates$srv_add_filter_state initialized, dataname: { private$dataname }"
337		)
338	!	NULL
339		}
340		)
341		}
342		)
343		)

1		#' @name RangeFilterState
2		#' @title `FilterState` object for numeric variable
3		#' @description Manages choosing a numeric range
4		#' @docType class
5		#' @keywords internal
6		#'
7		#'
8		#' @examples
9		#' filter_state <- teal.slice:::RangeFilterState$new(
10		#' c(NA, Inf, seq(1:10)),
11		#' varname = "x",
12		#' dataname = "data",
13		#' extract_type = character(0)
14		#' )
15		#' isolate(filter_state$get_call())
16		#' isolate(filter_state$set_selected(c(3L, 8L)))
17		#' isolate(filter_state$set_keep_na(TRUE))
18		#' isolate(filter_state$set_keep_inf(TRUE))
19		#' isolate(filter_state$get_call())
20		#'
21		#' \dontrun{
22		#' # working filter in an app
23		#' library(shiny)
24		#'
25		#' data_range <- c(runif(100, 0, 1), NA, Inf)
26		#' filter_state_range <- RangeFilterState$new(
27		#' x = data_range,
28		#' varname = "variable",
29		#' varlabel = "label"
30		#' )
31		#' filter_state_range$set_state(list(selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE))
32		#'
33		#' ui <- fluidPage(
34		#' column(4, div(
35		#' h4("RangeFilterState"),
36		#' isolate(filter_state_range$ui("fs"))
37		#' )),
38		#' column(4, div(
39		#' id = "outputs", # div id is needed for toggling the element
40		#' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
41		#' textOutput("condition_range"), br(),
42		#' h4("Unformatted state"), # display raw filter state
43		#' textOutput("unformatted_range"), br(),
44		#' h4("Formatted state"), # display human readable filter state
45		#' textOutput("formatted_range"), br()
46		#' )),
47		#' column(4, div(
48		#' h4("Programmatic filter control"),
49		#' actionButton("button1_range", "set drop NA", width = "100%"), br(),
50		#' actionButton("button2_range", "set keep NA", width = "100%"), br(),
51		#' actionButton("button3_range", "set drop Inf", width = "100%"), br(),
52		#' actionButton("button4_range", "set keep Inf", width = "100%"), br(),
53		#' actionButton("button5_range", "set a range", width = "100%"), br(),
54		#' actionButton("button6_range", "set full range", width = "100%"), br(),
55		#' actionButton("button0_range", "set initial state", width = "100%"), br()
56		#' ))
57		#' )
58		#'
59		#' server <- function(input, output, session) {
60		#' filter_state_range$server("fs")
61		#' output$condition_range <- renderPrint(filter_state_range$get_call())
62		#' output$formatted_range <- renderText(filter_state_range$format())
63		#' output$unformatted_range <- renderPrint(filter_state_range$get_state())
64		#' # modify filter state programmatically
65		#' observeEvent(input$button1_range, filter_state_range$set_keep_na(FALSE))
66		#' observeEvent(input$button2_range, filter_state_range$set_keep_na(TRUE))
67		#' observeEvent(input$button3_range, filter_state_range$set_keep_inf(FALSE))
68		#' observeEvent(input$button4_range, filter_state_range$set_keep_inf(TRUE))
69		#' observeEvent(input$button5_range, filter_state_range$set_selected(c(0.2, 0.74)))
70		#' observeEvent(input$button6_range, filter_state_range$set_selected(c(0, 1)))
71		#' observeEvent(
72		#' input$button0_range,
73		#' filter_state_range$set_state(list(selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE))
74		#' )
75		#' }
76		#'
77		#' if (interactive()) {
78		#' shinyApp(ui, server)
79		#' }
80		#' }
81		#'
82		RangeFilterState <- R6::R6Class( # nolint
83		"RangeFilterState",
84		inherit = FilterState,
85
86		# public methods ----
87		public = list(
88
89		#' @description
90		#' Initialize a `FilterState` object
91		#' @param x (`numeric`)\cr
92		#' values of the variable used in filter
93		#' @param varname (`character`, `name`)\cr
94		#' name of the variable
95		#' @param varlabel (`character(1)`)\cr
96		#' label of the variable (optional).
97		#' @param dataname (`character(1)`)\cr
98		#' optional name of dataset where `x` is taken from
99		#' @param extract_type (`character(0)`, `character(1)`)\cr
100		#' whether condition calls should be prefixed by dataname. Possible values:
101		#' \itemize{
102		#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
103		#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
104		#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
105		#' }
106		initialize = function(x,
107		varname,
108		varlabel = character(0),
109		dataname = NULL,
110		extract_type = character(0)) {
111	88x	checkmate::assert_numeric(x, all.missing = FALSE)
112	2x	if (!any(is.finite(x))) stop("\"x\" contains no finite values")
113
114	86x	super$initialize(x, varname, varlabel, dataname, extract_type)
115	86x	private$inf_count <- sum(is.infinite(x))
116	86x	private$is_integer <- checkmate::test_integerish(x)
117	86x	private$keep_inf <- reactiveVal(FALSE)
118
119	86x	x_range <- range(x, finite = TRUE)
120	86x	x_pretty <- pretty(x_range, 100L)
121
122	86x	if (identical(diff(x_range), 0)) {
123	11x	private$set_choices(x_range)
124	11x	private$slider_ticks <- signif(x_range, digits = 10)
125	11x	private$slider_step <- NULL
126	11x	self$set_selected(x_range)
127		} else {
128	75x	private$set_choices(range(x_pretty))
129	75x	private$slider_ticks <- signif(x_pretty, digits = 10)
130	75x	private$slider_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10)
131	75x	self$set_selected(range(x_pretty))
132		}
133
134	86x	private$histogram_data <- if (sum(is.finite(x)) >= 2) {
135	75x	as.data.frame(
136	75x	stats::density(x, na.rm = TRUE, n = 100)[c("x", "y")] # 100 bins only
137		)
138		} else {
139	11x	data.frame(x = NA_real_, y = NA_real_)
140		}
141
142	86x	return(invisible(self))
143		},
144
145		#' @description
146		#' Returns a formatted string representing this `RangeFilterState`.
147		#'
148		#' @param indent (`numeric(1)`)
149		#' the number of spaces before after each new line character of the formatted string.
150		#' Default: 0
151		#' @return `character(1)` the formatted string
152		#'
153		format = function(indent = 0) {
154	33x	checkmate::assert_number(indent, finite = TRUE, lower = 0)
155
156	32x	vals <- self$get_selected()
157	32x	sprintf(
158	32x	"%sFiltering on: %s\n%1$s Selected range: %s - %s\n%1$s Include missing values: %s",
159	32x	format("", width = indent),
160	32x	private$varname,
161	32x	format(vals[1], nsmall = 3),
162	32x	format(vals[2], nsmall = 3),
163	32x	format(self$get_keep_na())
164		)
165		},
166
167		#' @description
168		#' Answers the question of whether the current settings and values selected actually filters out any values.
169		#' @return logical scalar
170		is_any_filtered = function() {
171	29x	if (!isTRUE(all.equal(self$get_selected(), private$choices))) {
172	20x	TRUE
173	9x	} else if (!isTRUE(self$get_keep_inf()) && private$inf_count > 0) {
174	2x	TRUE
175	7x	} else if (!isTRUE(self$get_keep_na()) && private$na_count > 0) {
176	2x	TRUE
177		} else {
178	5x	FALSE
179		}
180		},
181
182		#' @description
183		#' Returns reproducible condition call for current selection.
184		#' For this class returned call looks like
185		#' `<varname> >= <min value> & <varname> <= <max value>` with
186		#' optional `is.na(<varname>)` and `is.finite(<varname>)`.
187		#' @return (`call`)
188		get_call = function() {
189	31x	filter_call <-
190	31x	call(
191		"&",
192	31x	call(">=", private$get_varname_prefixed(), self$get_selected()[1L]),
193	31x	call("<=", private$get_varname_prefixed(), self$get_selected()[2L])
194		)
195	31x	private$add_keep_na_call(private$add_keep_inf_call(filter_call))
196		},
197
198		#' @description
199		#' Returns current `keep_inf` selection
200		#' @return (`logical(1)`)
201		get_keep_inf = function() {
202	70x	private$keep_inf()
203		},
204
205		#' @description
206		#' Returns the filtering state.
207		#'
208		#' @return `list` containing values taken from the reactive fields:
209		#' * `selected` (`numeric(2)`) range of the filter.
210		#' * `keep_na` (`logical(1)`) whether `NA` should be kept.
211		#' * `keep_inf` (`logical(1)`) whether `Inf` should be kept.
212		get_state = function() {
213	28x	list(
214	28x	selected = self$get_selected(),
215	28x	keep_na = self$get_keep_na(),
216	28x	keep_inf = self$get_keep_inf()
217		)
218		},
219
220		#' @description
221		#' Set if `Inf` should be kept
222		#' @param value (`logical(1)`)\cr
223		#' Value(s) which come from the filter selection. Value is set in `server`
224		#' modules after selecting check-box-input in the shiny interface. Values are set to
225		#' `private$keep_inf` which is reactive.
226		set_keep_inf = function(value) {
227	36x	checkmate::assert_flag(value)
228	36x	private$keep_inf(value)
229	36x	logger::log_trace(
230	36x	sprintf(
231	36x	"%s$set_keep_inf of variable %s set to %s, dataname: %s.",
232	36x	class(self)[1],
233	36x	private$varname,
234	36x	value,
235	36x	private$dataname
236		)
237		)
238		},
239
240		#' @description
241		#' Set state
242		#' @param state (`list`)\cr
243		#' contains fields relevant for a specific class
244		#' \itemize{
245		#' \item{`selected`}{ defines initial selection}
246		#' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
247		#' \item{`keep_inf` (`logical`)}{ defines whether to keep or remove `Inf` values}
248		#' }
249		set_state = function(state) {
250	67x	stopifnot(is.list(state) && all(names(state) %in% c("selected", "keep_na", "keep_inf")))
251	66x	if (!is.null(state$keep_inf)) {
252	27x	self$set_keep_inf(state$keep_inf)
253		}
254	66x	super$set_state(state[names(state) %in% c("selected", "keep_na")])
255	66x	invisible(NULL)
256		},
257
258		#' @description
259		#' Sets the selected values of this `RangeFilterState`.
260		#'
261		#' @param value (`numeric(2)`) the two-elements array of the lower and upper bound
262		#' of the selected range. Must not contain NA values.
263		#'
264		#' @returns invisibly `NULL`
265		#'
266		#' @note Casts the passed object to `numeric` before validating the input
267		#' making it possible to pass any object coercible to `numeric` to this method.
268		#'
269		#' @examples
270		#' filter <- teal.slice:::RangeFilterState$new(c(1, 2, 3, 4), varname = "name")
271		#' filter$set_selected(c(2, 3))
272		#'
273		set_selected = function(value) {
274	158x	super$set_selected(value)
275		}
276		),
277
278		# private fields----
279		private = list(
280		histogram_data = data.frame(),
281		keep_inf = NULL, # because it holds reactiveVal
282		inf_count = integer(0),
283		is_integer = logical(0),
284		slider_step = numeric(0), # step for the slider input widget, calculated from input data (x)
285		slider_ticks = numeric(0), # allowed values for the slider input widget, calculated from input data (x)
286
287		# private methods ----
288		# Adds is.infinite(varname) before existing condition calls if keep_inf is selected
289		# returns a call
290		add_keep_inf_call = function(filter_call) {
291	31x	if (isTRUE(self$get_keep_inf())) {
292	3x	call("\|", call("is.infinite", private$get_varname_prefixed()), filter_call)
293		} else {
294	28x	filter_call
295		}
296		},
297
298		# @description gets pretty step size for range slider
299		# adaptation of shiny's method (see shiny/R/input-slider.R function findStepSize)
300		# @param pretty_range (numeric(n)) vector of pretty values
301		# @return numeric(1) pretty step size for the sliderInput
302		get_pretty_range_step = function(pretty_range) {
303	77x	if (private$is_integer && diff(range(pretty_range) > 2)) {
304	12x	return(1L)
305		} else {
306	65x	n_steps <- length(pretty_range) - 1
307	65x	return(
308	65x	signif(digits = 10, (max(pretty_range) - min(pretty_range)) / n_steps)
309		)
310		}
311		},
312
313		# overwrites superclass method
314		validate_selection = function(value) {
315	157x	if (!is.numeric(value)) {
316	!	stop(
317	!	sprintf(
318	!	"value of the selection for `%s` in `%s` should be a numeric",
319	!	self$get_varname(),
320	!	self$get_dataname()
321		)
322		)
323		}
324	157x	invisible(NULL)
325		},
326
327		# overwrites superclass method
328		# additionally adjusts progtammatic selection to existing slider ticks
329		cast_and_validate = function(values) {
330	1x	if (!is.atomic(values)) stop("Values to set must be an atomic vector.")
331	157x	values <- as.numeric(values)
332	!	if (any(is.na(values))) stop("The array of set values must contain values coercible to numeric.")
333	!	if (length(values) != 2) stop("The array of set values must have length two.")
334
335	157x	values_adjusted <- contain_interval(values, private$slider_ticks)
336	157x	if (!isTRUE(all.equal(values, values_adjusted))) {
337	1x	logger::log_warn(sprintf(
338	1x	paste(
339	1x	"Programmatic range specification on %s was adjusted to existing slider ticks.",
340	1x	"It is now broader in order to contain the specified values."
341		),
342	1x	private$varname
343		))
344		}
345	157x	values_adjusted
346		},
347		# for numeric ranges selecting out of bound values is allowed
348		remove_out_of_bound_values = function(values) {
349	157x	values
350		},
351
352		# shiny modules ----
353
354		# UI Module for `RangeFilterState`.
355		# This UI element contains two values for `min` and `max`
356		# of the range and two checkboxes whether to keep the `NA` or `Inf` values.
357		# @param id (`character(1)`)\cr
358		# id of shiny element
359		ui_inputs = function(id) {
360	!	ns <- NS(id)
361	!	fluidRow(
362	!	div(
363	!	class = "filterPlotOverlayRange",
364	!	plotOutput(ns("plot"), height = "100%")
365		),
366	!	div(
367	!	class = "filterRangeSlider",
368	!	teal.widgets::optionalSliderInput(
369	!	inputId = ns("selection"),
370	!	label = NULL,
371	!	min = private$choices[1],
372	!	max = private$choices[2],
373	!	value = isolate(private$selected()),
374	!	step = private$slider_step,
375	!	width = "100%"
376		)
377		),
378	!	private$keep_inf_ui(ns("keep_inf")),
379	!	private$keep_na_ui(ns("keep_na"))
380		)
381		},
382
383		# @description
384		# Server module
385		# @param id (`character(1)`)\cr
386		# an ID string that corresponds with the ID used to call the module's UI function.
387		# return `moduleServer` function which returns `NULL`
388		server_inputs = function(id) {
389	!	moduleServer(
390	!	id = id,
391	!	function(input, output, session) {
392	!	logger::log_trace("RangeFilterState$server initializing, dataname: { private$dataname }")
393
394	!	output$plot <- renderPlot(
395	!	bg = "transparent",
396	!	height = 25,
397	!	expr = {
398	!	ggplot2::ggplot(private$histogram_data) +
399	!	ggplot2::aes_string(x = "x", y = "y") +
400	!	ggplot2::geom_area(
401	!	fill = grDevices::rgb(66 / 255, 139 / 255, 202 / 255),
402	!	color = NA,
403	!	alpha = 0.2
404		) +
405	!	ggplot2::theme_void() +
406	!	ggplot2::scale_y_continuous(expand = c(0, 0)) +
407	!	ggplot2::scale_x_continuous(expand = c(0, 0))
408		}
409		)
410
411		# this observer is needed in the situation when private$selected has been
412		# changed directly by the api - then it's needed to rerender UI element
413		# to show relevant values
414	!	private$observers$selection_api <- observeEvent(
415	!	ignoreNULL = FALSE,
416	!	ignoreInit = TRUE,
417	!	eventExpr = self$get_selected(),
418	!	handlerExpr = {
419	!	if (!isTRUE(all.equal(input$selection, self$get_selected()))) {
420	!	updateSliderInput(
421	!	session = session,
422	!	inputId = "selection",
423	!	value = private$selected()
424		)
425		}
426		}
427		)
428
429	!	private$observers$selection <- observeEvent(
430	!	ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in `selectInput`
431	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
432	!	eventExpr = input$selection,
433	!	handlerExpr = {
434	!	if (!isTRUE(all.equal(input$selection, self$get_selected()))) {
435	!	self$set_selected(input$selection)
436		}
437	!	logger::log_trace(
438	!	sprintf(
439	!	"RangeFilterState$server@3 selection of variable %s changed, dataname: %s",
440	!	private$varname,
441	!	private$dataname
442		)
443		)
444		}
445		)
446
447	!	private$keep_inf_srv("keep_inf")
448	!	private$keep_na_srv("keep_na")
449
450	!	logger::log_trace("RangeFilterState$server initialized, dataname: { private$dataname }")
451	!	NULL
452		}
453		)
454		},
455
456		# @description
457		# module displaying input to keep or remove Inf in the FilterState call
458		# @param id `shiny` id parameter
459		# renders checkbox input only when variable from which FilterState has
460		# been created has some Inf values.
461		keep_inf_ui = function(id) {
462	!	ns <- NS(id)
463	!	if (private$inf_count > 0) {
464	!	checkboxInput(
465	!	ns("value"),
466	!	sprintf("Keep Inf (%s)", private$inf_count),
467	!	value = self$get_keep_inf()
468		)
469		} else {
470	!	NULL
471		}
472		},
473
474		# @description
475		# module to handle Inf values in the FilterState
476		# @param shiny `id` parametr passed to moduleServer
477		# module sets `private$keep_inf` according to the selection.
478		# Module also updates a UI element if the `private$keep_inf` has been
479		# changed through the api
480		keep_inf_srv = function(id) {
481	!	moduleServer(id, function(input, output, session) {
482		# this observer is needed in the situation when private$keep_na has been
483		# changed directly by the api - then it's needed to rerender UI element
484		# to show relevant values
485	!	private$observers$keep_inf_api <- observeEvent(
486	!	ignoreNULL = TRUE, # its not possible for range that NULL is selected
487	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
488	!	eventExpr = self$get_keep_inf(),
489	!	handlerExpr = {
490	!	if (!setequal(self$get_keep_inf(), input$value)) {
491	!	updateCheckboxInput(
492	!	inputId = "value",
493	!	value = self$get_keep_inf()
494		)
495		}
496		}
497		)
498	!	private$observers$keep_inf <- observeEvent(
499	!	ignoreNULL = TRUE, # it's not possible for range that NULL is selected
500	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
501	!	eventExpr = input$value,
502	!	handlerExpr = {
503	!	keep_inf <- input$value
504	!	self$set_keep_inf(keep_inf)
505	!	logger::log_trace(
506	!	sprintf(
507	!	"%s$server keep_inf of variable %s set to: %s, dataname: %s",
508	!	class(self)[1],
509	!	private$varname,
510	!	deparse1(input$value),
511	!	private$dataname
512		)
513		)
514		}
515		)
516	!	invisible(NULL)
517		})
518		}
519		)
520		)

1		#' @rdname DatetimeFilterState
2		#' @title `FilterState` object for `POSIXct` variable
3		#' @description Manages choosing a range of date-times
4		#' @docType class
5		#' @keywords internal
6		#'
7		#'
8		#' @examples
9		#' filter_state <- teal.slice:::DatetimeFilterState$new(
10		#' c(Sys.time() + seq(0, by = 3600, length.out = 10), NA),
11		#' varname = "x",
12		#' dataname = "data",
13		#' extract_type = character(0)
14		#' )
15		#'
16		#' isolate(filter_state$get_call())
17		#' isolate(filter_state$set_selected(c(Sys.time() + 3L, Sys.time() + 8L)))
18		#' isolate(filter_state$set_keep_na(TRUE))
19		#' isolate(filter_state$get_call())
20		#'
21		#' \dontrun{
22		#' # working filter in an app
23		#' library(shiny)
24		#'
25		#' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00"))
26		#' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA)
27		#' filter_state_datetime <- DatetimeFilterState$new(
28		#' x = data_datetime,
29		#' varname = "variable",
30		#' varlabel = "label"
31		#' )
32		#' filter_state_datetime$set_state(list(selected = data_datetime[c(47, 98)], keep_na = TRUE))
33		#'
34		#' ui <- fluidPage(
35		#' column(4, div(
36		#' h4("DatetimeFilterState"),
37		#' isolate(filter_state_datetime$ui("fs"))
38		#' )),
39		#' column(4, div(
40		#' id = "outputs", # div id is needed for toggling the element
41		#' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
42		#' textOutput("condition_datetime"), br(),
43		#' h4("Unformatted state"), # display raw filter state
44		#' textOutput("unformatted_datetime"), br(),
45		#' h4("Formatted state"), # display human readable filter state
46		#' textOutput("formatted_datetime"), br()
47		#' )),
48		#' column(4, div(
49		#' h4("Programmatic filter control"),
50		#' actionButton("button1_datetime", "set drop NA", width = "100%"), br(),
51		#' actionButton("button2_datetime", "set keep NA", width = "100%"), br(),
52		#' actionButton("button3_datetime", "set a range", width = "100%"), br(),
53		#' actionButton("button4_datetime", "set full range", width = "100%"), br(),
54		#' actionButton("button0_datetime", "set initial state", width = "100%"), br()
55		#' ))
56		#' )
57		#'
58		#' server <- function(input, output, session) {
59		#' filter_state_datetime$server("fs")
60		#' output$condition_datetime <- renderPrint(filter_state_datetime$get_call())
61		#' output$formatted_datetime <- renderText(filter_state_datetime$format())
62		#' output$unformatted_datetime <- renderPrint(filter_state_datetime$get_state())
63		#' # modify filter state programmatically
64		#' observeEvent(input$button1_datetime, filter_state_datetime$set_keep_na(FALSE))
65		#' observeEvent(input$button2_datetime, filter_state_datetime$set_keep_na(TRUE))
66		#' observeEvent(
67		#' input$button3_datetime,
68		#' filter_state_datetime$set_selected(data_datetime[c(34, 56)])
69		#' )
70		#' observeEvent(input$button4_datetime, filter_state_datetime$set_selected(datetimes))
71		#' observeEvent(
72		#' input$button0_datetime,
73		#' filter_state_datetime$set_state(list(selected = data_datetime[c(47, 98)], keep_na = TRUE))
74		#' )
75		#' }
76		#'
77		#' if (interactive()) {
78		#' shinyApp(ui, server)
79		#' }
80		#' }
81		#'
82		DatetimeFilterState <- R6::R6Class( # nolint
83		"DatetimeFilterState",
84		inherit = FilterState,
85
86		# public methods ----
87
88		public = list(
89
90		#' @description
91		#' Initialize a `FilterState` object. This class
92		#' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by
93		#' default. However, in case when using this module in `teal` app, one needs
94		#' timezone of the app user. App user timezone is taken from `session$userData$timezone`
95		#' and is set only if object is initialized in `shiny`.
96		#' @param x (`POSIXct` or `POSIXlt`)\cr
97		#' values of the variable used in filter
98		#' @param varname (`character`, `name`)\cr
99		#' name of the variable
100		#' @param varlabel (`character(1)`)\cr
101		#' label of the variable (optional).
102		#' @param dataname (`character(1)`)\cr
103		#' optional name of dataset where `x` is taken from
104		#' @param extract_type (`character(0)`, `character(1)`)\cr
105		#' whether condition calls should be prefixed by dataname. Possible values:
106		#' \itemize{
107		#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
108		#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
109		#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
110		#' }
111		initialize = function(x,
112		varname,
113		varlabel = character(0),
114		dataname = NULL,
115		extract_type = character(0)) {
116	23x	checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
117	23x	super$initialize(x, varname, varlabel, dataname, extract_type)
118
119	23x	var_range <- as.POSIXct(trunc(range(x, na.rm = TRUE), units = "secs"))
120	23x	private$set_choices(var_range)
121	23x	self$set_selected(var_range)
122
123	23x	return(invisible(self))
124		},
125
126		#' @description
127		#' Returns a formatted string representing this `DatetimeFilterState`.
128		#'
129		#' @param indent (`numeric(1)`) the number of spaces before after each new line character of the formatted string.
130		#' Default: 0
131		#' @return `character(1)` the formatted string
132		#'
133		format = function(indent = 0) {
134	6x	checkmate::assert_number(indent, finite = TRUE, lower = 0)
135
136
137	5x	vals <- self$get_selected()
138	5x	sprintf(
139	5x	"%sFiltering on: %s\n%1$s Selected range: %s - %s\n%1$s Include missing values: %s",
140	5x	format("", width = indent),
141	5x	private$varname,
142	5x	format(vals[1], nsmall = 3),
143	5x	format(vals[2], nsmall = 3),
144	5x	format(self$get_keep_na())
145		)
146		},
147
148		#' @description
149		#' Answers the question of whether the current settings and values selected actually filters out any values.
150		#' @return logical scalar
151		is_any_filtered = function() {
152	6x	if (!setequal(self$get_selected(), private$choices)) {
153	4x	TRUE
154	2x	} else if (!isTRUE(self$get_keep_na()) && private$na_count > 0) {
155	1x	TRUE
156		} else {
157	1x	FALSE
158		}
159		},
160
161		#' @description
162		#' Returns reproducible condition call for current selection.
163		#' For this class returned call looks like
164		#' `<varname> >= as.POSIXct(<min>) & <varname> <= <max>)`
165		#' with optional `is.na(<varname>)`.
166		get_call = function() {
167	10x	choices <- self$get_selected()
168	10x	tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone"))
169	10x	class <- class(choices)[1L]
170	10x	date_fun <- as.name(switch(class,
171	10x	"POSIXct" = "as.POSIXct",
172	10x	"POSIXlt" = "as.POSIXlt"
173		))
174	10x	choices <- as.character(choices + c(0, 1))
175	10x	filter_call <-
176	10x	call(
177		"&",
178	10x	call(
179		">=",
180	10x	private$get_varname_prefixed(),
181	10x	as.call(list(date_fun, choices[1L], tz = tzone))
182		),
183	10x	call(
184		"<",
185	10x	private$get_varname_prefixed(),
186	10x	as.call(list(date_fun, choices[2L], tz = tzone))
187		)
188		)
189	10x	private$add_keep_na_call(filter_call)
190		},
191
192		#' @description
193		#' Sets the selected time frame of this `DatetimeFilterState`.
194		#'
195		#' @param value (`POSIX(2)`) the lower and the upper bound of the selected
196		#' time frame. Must not contain NA values.
197		#'
198		#' @return invisibly `NULL`.
199		#'
200		#' @note Casts the passed object to `POSIXct` before validating the input
201		#' making it possible to pass any object coercible to `POSIXct` to this method.
202		#'
203		#' @examples
204		#' date <- as.POSIXct(1, origin = "01/01/1970")
205		#' filter <- teal.slice:::DatetimeFilterState$new(
206		#' c(date, date + 1, date + 2, date + 3),
207		#' varname = "name"
208		#' )
209		#' filter$set_selected(c(date + 1, date + 2))
210		set_selected = function(value) {
211	41x	super$set_selected(value)
212		}
213		),
214
215		# private members ----
216
217		private = list(
218		# private methods ----
219		validate_selection = function(value) {
220	40x	if (!(is(value, "POSIXct") \|\| is(value, "POSIXlt"))) {
221	!	stop(
222	!	sprintf(
223	!	"value of the selection for `%s` in `%s` should be a POSIXct or POSIXlt",
224	!	self$get_varname(),
225	!	self$get_dataname()
226		)
227		)
228		}
229
230	40x	pre_msg <- sprintf(
231	40x	"dataset '%s', variable '%s': ",
232	40x	self$get_dataname(),
233	40x	self$get_varname()
234		)
235	40x	check_in_range(value, private$choices, pre_msg = pre_msg)
236		},
237		cast_and_validate = function(values) {
238	41x	tryCatch(
239	41x	expr = {
240	41x	values <- as.POSIXct(values)
241	!	if (any(is.na(values))) stop()
242		},
243	41x	error = function(error) stop("The array of set values must contain values coercible to POSIX.")
244		)
245	!	if (length(values) != 2) stop("The array of set values must have length two.")
246	40x	values
247		},
248		remove_out_of_bound_values = function(values) {
249	40x	if (values[1] < private$choices[1]) {
250	4x	warning(paste(
251	4x	"Value:", values[1], "is outside of the possible range for column", private$varname,
252	4x	"of dataset", private$dataname, "."
253		))
254	4x	values[1] <- private$choices[1]
255		}
256
257	40x	if (values[2] > private$choices[2]) {
258	5x	warning(paste(
259	5x	"Value:", values[2], "is outside of the possible range for column", private$varname,
260	5x	"of dataset", private$dataname, "."
261		))
262	5x	values[2] <- private$choices[2]
263		}
264	40x	values
265		},
266
267		# shiny modules ----
268
269		# @description
270		# UI Module for `DatetimeFilterState`.
271		# This UI element contains two date-time selections for `min` and `max`
272		# of the range and a checkbox whether to keep the `NA` values.
273		# @param id (`character(1)`)\cr
274		# id of shiny element
275		ui_inputs = function(id) {
276	!	ns <- NS(id)
277	!	div(
278	!	div(
279	!	class = "flex",
280	!	actionButton(
281	!	class = "date_reset_button",
282	!	inputId = ns("start_date_reset"),
283	!	label = NULL,
284	!	icon = icon("fas fa-undo")
285		),
286	!	div(
287	!	class = "flex w-80 filter_datelike_input",
288	!	div(class = "w-45 text-center", {
289	!	x <- shinyWidgets::airDatepickerInput(
290	!	inputId = ns("selection_start"),
291	!	value = self$get_selected()[1],
292	!	startView = self$get_selected()[1],
293	!	timepicker = TRUE,
294	!	minDate = private$choices[1],
295	!	maxDate = private$choices[2],
296	!	update_on = "close",
297	!	addon = "none",
298	!	position = "bottom right"
299		)
300	!	x$children[[2]]$attribs <- c(x$children[[2]]$attribs, list(class = "input-sm"))
301	!	x
302		}),
303	!	span(
304	!	class = "input-group-addon w-10",
305	!	span(class = "input-group-text w-100 justify-content-center", "to"),
306	!	title = "Times are displayed in the local timezone and are converted to UTC in the analysis"
307		),
308	!	div(class = "w-45 text-center", {
309	!	x <- shinyWidgets::airDatepickerInput(
310	!	inputId = ns("selection_end"),
311	!	value = self$get_selected()[2],
312	!	startView = self$get_selected()[2],
313	!	timepicker = TRUE,
314	!	minDate = private$choices[1],
315	!	maxDate = private$choices[2],
316	!	update_on = "close",
317	!	addon = "none",
318	!	position = "bottom right"
319		)
320	!	x$children[[2]]$attribs <- c(x$children[[2]]$attribs, list(class = "input-sm"))
321	!	x
322		})
323		),
324	!	actionButton(
325	!	class = "date_reset_button",
326	!	inputId = ns("end_date_reset"),
327	!	label = NULL,
328	!	icon = icon("fas fa-undo")
329		)
330		),
331	!	private$keep_na_ui(ns("keep_na"))
332		)
333		},
334
335		# @description
336		# Server module
337		# @param id (`character(1)`)\cr
338		# an ID string that corresponds with the ID used to call the module's UI function.
339		# @return `moduleServer` function which returns `NULL`
340		server_inputs = function(id) {
341	!	moduleServer(
342	!	id = id,
343	!	function(input, output, session) {
344	!	logger::log_trace("DatetimeFilterState$server initializing, dataname: { private$dataname }")
345
346		# this observer is needed in the situation when private$selected has been
347		# changed directly by the api - then it's needed to rerender UI element
348		# to show relevant values
349	!	private$observers$selection_api <- observeEvent(
350	!	ignoreNULL = TRUE, # dates needs to be selected
351	!	ignoreInit = TRUE, # on init selected == default, so no need to trigger
352	!	eventExpr = self$get_selected(),
353	!	handlerExpr = {
354	!	start_date <- input$selection_start
355	!	end_date <- input$selection_end
356	!	if (!all(self$get_selected() == c(start_date, end_date))) {
357	!	if (self$get_selected()[1] != start_date) {
358	!	shinyWidgets::updateAirDateInput(
359	!	session = session,
360	!	inputId = "selection_start",
361	!	value = self$get_selected()[1]
362		)
363		}
364
365	!	if (self$get_selected()[2] != end_date) {
366	!	shinyWidgets::updateAirDateInput(
367	!	session = session,
368	!	inputId = "selection_end",
369	!	value = self$get_selected()[2]
370		)
371		}
372
373	!	logger::log_trace(sprintf(
374	!	"DatetimeFilterState$server@1 selection of variable %s changed, dataname: %s",
375	!	private$varname,
376	!	private$dataname
377		))
378		}
379		}
380		)
381
382
383	!	private$observers$selection <- observeEvent(
384	!	ignoreNULL = TRUE, # dates needs to be selected
385	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
386	!	eventExpr = {
387	!	input$selection_start
388	!	input$selection_end
389		},
390	!	handlerExpr = {
391	!	start_date <- input$selection_start
392	!	end_date <- input$selection_end
393	!	tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$choices), "tzone"))
394	!	attr(start_date, "tzone") <- tzone
395	!	attr(end_date, "tzone") <- tzone
396
397	!	if (start_date < private$choices[1]) {
398	!	start_date <- private$choices[1]
399		}
400
401	!	if (end_date > private$choices[2]) {
402	!	end_date <- private$choices[2]
403		}
404
405	!	self$set_selected(c(start_date, end_date))
406	!	logger::log_trace(sprintf(
407	!	"DatetimeFilterState$server@2 selection of variable %s changed, dataname: %s",
408	!	private$varname,
409	!	private$dataname
410		))
411		}
412		)
413
414	!	private$keep_na_srv("keep_na")
415
416	!	private$observers$reset1 <- observeEvent(
417	!	ignoreInit = TRUE, # reset button shouldn't be trigger on init
418	!	ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL
419	!	input$start_date_reset,
420		{
421	!	shinyWidgets::updateAirDateInput(
422	!	session = session,
423	!	inputId = "selection_start",
424	!	value = private$choices[1]
425		)
426	!	logger::log_trace(sprintf(
427	!	"DatetimeFilterState$server@2 reset start date of variable %s, dataname: %s",
428	!	private$varname,
429	!	private$dataname
430		))
431		}
432		)
433	!	private$observers$reset2 <- observeEvent(
434	!	ignoreInit = TRUE, # reset button shouldn't be trigger on init
435	!	ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL
436	!	input$end_date_reset,
437		{
438	!	shinyWidgets::updateAirDateInput(
439	!	session = session,
440	!	inputId = "selection_end",
441	!	value = private$choices[2]
442		)
443	!	logger::log_trace(sprintf(
444	!	"DatetimeFilterState$server@3 reset end date of variable %s, dataname: %s",
445	!	private$varname,
446	!	private$dataname
447		))
448		}
449		)
450	!	logger::log_trace("DatetimeFilterState$server initialized, dataname: { private$dataname }")
451	!	NULL
452		}
453		)
454		}
455		)
456		)

1		#' @name ChoicesFilterState
2		#' @title `FilterState` object for factor or character variable
3		#' @description Manages choosing elements from a set
4		#' @docType class
5		#' @keywords internal
6		#'
7		#'
8		#' @examples
9		#' filter_state <- teal.slice:::ChoicesFilterState$new(
10		#' c(LETTERS, NA),
11		#' varname = "x",
12		#' dataname = "data",
13		#' extract_type = character(0)
14		#' )
15		#' isolate(filter_state$get_call())
16		#' isolate(filter_state$set_selected("B"))
17		#' isolate(filter_state$set_keep_na(TRUE))
18		#' isolate(filter_state$get_call())
19		#'
20		#' \dontrun{
21		#' # working filter in an app
22		#' library(shiny)
23		#'
24		#' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA)
25		#' filter_state_choices <- ChoicesFilterState$new(
26		#' x = data_choices,
27		#' varname = "variable",
28		#' varlabel = "label"
29		#' )
30		#' filter_state_choices$set_state(list(selected = c("a", "c"), keep_na = TRUE))
31		#'
32		#' ui <- fluidPage(
33		#' column(4, div(
34		#' h4("ChoicesFilterState"),
35		#' isolate(filter_state_choices$ui("fs"))
36		#' )),
37		#' column(4, div(
38		#' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
39		#' textOutput("condition_choices"), br(),
40		#' h4("Unformatted state"), # display raw filter state
41		#' textOutput("unformatted_choices"), br(),
42		#' h4("Formatted state"), # display human readable filter state
43		#' textOutput("formatted_choices"), br()
44		#' )),
45		#' column(4, div(
46		#' h4("Programmatic filter control"),
47		#' actionButton("button1_choices", "set drop NA", width = "100%"), br(),
48		#' actionButton("button2_choices", "set keep NA", width = "100%"), br(),
49		#' actionButton("button3_choices", "set a selection", width = "100%"), br(),
50		#' actionButton("button4_choices", "deselect all", width = "100%"), br(),
51		#' actionButton("button0_choices", "set initial state", width = "100%"), br()
52		#' ))
53		#' )
54		#'
55		#' server <- function(input, output, session) {
56		#' filter_state_choices$server("fs")
57		#' output$condition_choices <- renderPrint(filter_state_choices$get_call())
58		#' output$formatted_choices <- renderText(filter_state_choices$format())
59		#' output$unformatted_choices <- renderPrint(filter_state_choices$get_state())
60		#' # modify filter state programmatically
61		#' observeEvent(input$button1_choices, filter_state_choices$set_keep_na(FALSE))
62		#' observeEvent(input$button2_choices, filter_state_choices$set_keep_na(TRUE))
63		#' observeEvent(
64		#' input$button3_choices,
65		#' filter_state_choices$set_selected(c("b", "c"))
66		#' )
67		#' observeEvent(input$button4_choices, filter_state_choices$set_selected(c()))
68		#' observeEvent(
69		#' input$button0_choices,
70		#' filter_state_choices$set_state(list(selected = c("a", "c"), keep_na = TRUE))
71		#' )
72		#' }
73		#'
74		#' if (interactive()) {
75		#' shinyApp(ui, server)
76		#' }
77		#' }
78		#'
79		ChoicesFilterState <- R6::R6Class( # nolint
80		"ChoicesFilterState",
81		inherit = FilterState,
82
83		# public methods ----
84
85		public = list(
86
87		#' @description
88		#' Initialize a `FilterState` object
89		#' @param x (`character` or `factor`)\cr
90		#' values of the variable used in filter
91		#' @param varname (`character`)\cr
92		#' name of the variable
93		#' @param varlabel (`character(1)`)\cr
94		#' label of the variable (optional).
95		#' @param dataname (`character(1)`)\cr
96		#' optional name of dataset where `x` is taken from
97		#' @param extract_type (`character(0)`, `character(1)`)\cr
98		#' whether condition calls should be prefixed by dataname. Possible values:
99		#' \itemize{
100		#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
101		#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
102		#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
103		#' }
104		initialize = function(x,
105		varname,
106		varlabel = character(0),
107		dataname = NULL,
108		extract_type = character(0)) {
109	144x	checkmate::assert(
110	144x	is.character(x),
111	144x	is.factor(x),
112	144x	length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
113	144x	combine = "or"
114		)
115	144x	super$initialize(x, varname, varlabel, dataname, extract_type)
116
117	144x	private$data_class <- class(x)[1L]
118	144x	if (inherits(x, "POSIXt")) {
119	12x	private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))
120		}
121
122	144x	if (!is.factor(x)) {
123	113x	x <- factor(as.character(x), levels = as.character(sort(unique(x))))
124		}
125	144x	x <- droplevels(x)
126	144x	tbl <- table(x)
127	144x	choices <- names(tbl)
128	144x	names(choices) <- tbl
129
130
131	144x	private$set_choices(as.list(choices))
132	144x	self$set_selected(unname(choices))
133	144x	private$histogram_data <- data.frame(
134	144x	x = levels(x),
135	144x	y = tabulate(x)
136		)
137
138	144x	return(invisible(self))
139		},
140
141		#' @description
142		#' Answers the question of whether the current settings and values selected actually filters out any values.
143		#' @return logical scalar
144		is_any_filtered = function() {
145	44x	if (!setequal(self$get_selected(), private$choices)) {
146	37x	TRUE
147	7x	} else if (!isTRUE(self$get_keep_na()) && private$na_count > 0) {
148	3x	TRUE
149		} else {
150	4x	FALSE
151		}
152		},
153
154		#' @description
155		#' Returns reproducible condition call for current selection.
156		#' For this class returned call looks like
157		#' `<varname> %in% c(<values selected>)` with
158		#' optional `is.na(<varname>)`.
159		#' @return (`call`)
160		get_call = function() {
161	61x	varname <- private$get_varname_prefixed()
162	61x	choices <- self$get_selected()
163	61x	if (private$data_class != "factor") {
164	50x	choices <- do.call(sprintf("as.%s", private$data_class), list(x = choices))
165		}
166	61x	fun_compare <- if (length(choices) == 1L) "==" else "%in%"
167	61x	filter_call <-
168	61x	if (inherits(choices, "Date")) {
169	4x	call(fun_compare, varname, call("as.Date", as.character(choices)))
170	61x	} else if (inherits(choices, c("POSIXct", "POSIXlt"))) {
171	8x	class <- class(choices)[1L]
172	8x	date_fun <- as.name(switch(class,
173	8x	"POSIXct" = "as.POSIXct",
174	8x	"POSIXlt" = "as.POSIXlt"
175		))
176	8x	call(fun_compare, varname, as.call(list(date_fun, as.character(choices), tz = private$tzone)))
177		} else {
178		# This handles numerics, characters, and factors.
179	49x	call(fun_compare, varname, choices)
180		}
181	61x	private$add_keep_na_call(filter_call)
182		},
183
184		#' @description
185		#' Set state
186		#' @param state (`list`)\cr
187		#' contains fields relevant for a specific class
188		#' \itemize{
189		#' \item{`selected`}{ defines initial selection}
190		#' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
191		#' }
192		set_state = function(state) {
193	100x	if (!is.null(state$selected)) {
194	100x	state$selected <- as.character(state$selected)
195		}
196	100x	super$set_state(state)
197	99x	invisible(NULL)
198		},
199
200		#' @description
201		#' Sets the selected values of this `ChoicesFilterState`.
202		#'
203		#' @param value (`character`) the array of the selected choices.
204		#' Must not contain NA values.
205		#'
206		#' @return invisibly `NULL`
207		#'
208		#' @note Casts the passed object to `character` before validating the input
209		#' making it possible to pass any object coercible to `character` to this method.
210		#'
211		#' @examples
212		#' filter <- teal.slice:::ChoicesFilterState$new(c("a", "b", "c"), varname = "name")
213		#' filter$set_selected(c("c", "a"))
214		set_selected = function(value) {
215	282x	super$set_selected(value)
216		}
217		),
218
219		# private members ----
220
221		private = list(
222		histogram_data = data.frame(),
223		data_class = character(0), # stores class of filtered variable so that it can be restored in $get_call
224		tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call
225
226		# private methods ----
227		validate_selection = function(value) {
228	282x	if (!is.character(value)) {
229	!	stop(
230	!	sprintf(
231	!	"Values of the selection for `%s` in `%s` should be an array of character.",
232	!	self$get_varname(),
233	!	self$get_dataname()
234		)
235		)
236		}
237	282x	pre_msg <- sprintf(
238	282x	"data '%s', variable '%s': ",
239	282x	self$get_dataname(),
240	282x	self$get_varname()
241		)
242	282x	check_in_subset(value, private$choices, pre_msg = pre_msg)
243		},
244		cast_and_validate = function(values) {
245	282x	tryCatch(
246	282x	expr = {
247	282x	values <- as.character(values)
248	!	if (any(is.na(values))) stop()
249		},
250	282x	error = function(error) stop("The array of set values must contain values coercible to character.")
251		)
252	282x	values
253		},
254		remove_out_of_bound_values = function(values) {
255	282x	in_choices_mask <- values %in% private$choices
256	282x	if (length(values[!in_choices_mask]) > 0) {
257	18x	warning(paste(
258	18x	"Values:", strtrim(paste(values[!in_choices_mask], collapse = ", "), 360),
259	18x	"are not in choices of column", private$varname, "in dataset", private$dataname, "."
260		))
261		}
262	282x	values[in_choices_mask]
263		},
264
265		# shiny modules ----
266
267		# @description
268		# UI Module for `ChoicesFilterState`.
269		# This UI element contains available choices selection and
270		# checkbox whether to keep or not keep the `NA` values.
271		# @param id (`character(1)`)\cr
272		# id of shiny element
273		ui_inputs = function(id) {
274	!	ns <- NS(id)
275	!	div(
276	!	if (length(private$choices) <= getOption("teal.threshold_slider_vs_checkboxgroup")) {
277	!	l_counts <- as.numeric(names(private$choices))
278	!	l_counts[is.na(l_counts)] <- 0
279	!	l_freqs <- l_counts / sum(l_counts)
280	!	labels <- lapply(seq_along(private$choices), function(i) {
281	!	div(
282	!	class = "choices_state_label",
283	!	style = sprintf("width:%s%%", l_freqs[i] * 100),
284	!	span(
285	!	class = "choices_state_label_text",
286	!	sprintf(
287	!	"%s (%s)",
288	!	private$choices[i],
289	!	l_counts[i]
290		)
291		)
292		)
293		})
294	!	div(
295	!	class = "choices_state",
296	!	checkboxGroupInput(
297	!	ns("selection"),
298	!	label = NULL,
299	!	selected = self$get_selected(),
300	!	choiceNames = labels,
301	!	choiceValues = as.character(private$choices),
302	!	width = "100%"
303		)
304		)
305		} else {
306	!	teal.widgets::optionalSelectInput(
307	!	inputId = ns("selection"),
308	!	choices = stats::setNames(private$choices, sprintf("%s (%s)", private$choices, names(private$choices))),
309	!	selected = self$get_selected(),
310	!	multiple = TRUE,
311	!	options = shinyWidgets::pickerOptions(
312	!	actionsBox = TRUE,
313	!	liveSearch = (length(private$choices) > 10),
314	!	noneSelectedText = "Select a value"
315		)
316		)
317		},
318	!	private$keep_na_ui(ns("keep_na"))
319		)
320		},
321
322		# @description
323		# Server module
324		# @param id (`character(1)`)\cr
325		# an ID string that corresponds with the ID used to call the module's UI function.
326		# @return `moduleServer` function which returns `NULL`
327		server_inputs = function(id) {
328	!	moduleServer(
329	!	id = id,
330	!	function(input, output, session) {
331	!	logger::log_trace("ChoicesFilterState$server initializing, dataname: { private$dataname }")
332
333		# this observer is needed in the situation when private$selected has been
334		# changed directly by the api - then it's needed to rerender UI element
335		# to show relevant values
336	!	private$observers$selection_api <- observeEvent(
337	!	ignoreNULL = FALSE, # it's possible that nothing is selected
338	!	ignoreInit = TRUE,
339	!	eventExpr = self$get_selected(),
340	!	handlerExpr = {
341	!	if (!setequal(self$get_selected(), input$selection)) {
342	!	updateCheckboxInput(
343	!	session = session,
344	!	inputId = "selection",
345	!	value = self$get_selected()
346		)
347	!	logger::log_trace(sprintf(
348	!	"ChoicesFilterState$server@1 selection of variable %s changed, dataname: %s",
349	!	private$varname,
350	!	private$dataname
351		))
352		}
353		}
354		)
355
356	!	private$observers$selection <- observeEvent(
357	!	ignoreNULL = FALSE, # it's possible that nothing is selected
358	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
359	!	eventExpr = input$selection,
360	!	handlerExpr = {
361	!	selection <- if (is.null(input$selection)) character(0) else input$selection
362	!	self$set_selected(selection)
363	!	logger::log_trace(sprintf(
364	!	"ChoicesFilterState$server@2 selection of variable %s changed, dataname: %s",
365	!	private$varname,
366	!	private$dataname
367		))
368		}
369		)
370	!	private$keep_na_srv("keep_na")
371
372	!	logger::log_trace("ChoicesFilterState$server initialized, dataname: { private$dataname }")
373	!	NULL
374		}
375		)
376		}
377		)
378		)

1		#' @name LogicalFilterState
2		#' @title `FilterState` object for logical variable
3		#' @description Manages choosing a logical state
4		#' @docType class
5		#' @keywords internal
6		#'
7		#'
8		#' @examples
9		#' filter_state <- teal.slice:::LogicalFilterState$new(
10		#' sample(c(TRUE, FALSE, NA), 10, replace = TRUE),
11		#' varname = "x",
12		#' dataname = "data",
13		#' extract_type = character(0)
14		#' )
15		#' isolate(filter_state$get_call())
16		#'
17		#' isolate(filter_state$set_selected(TRUE))
18		#' isolate(filter_state$set_keep_na(TRUE))
19		#' isolate(filter_state$get_call())
20		#'
21		#' \dontrun{
22		#' # working filter in an app
23		#' library(shiny)
24		#'
25		#' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA)
26		#' filter_state_logical <- LogicalFilterState$new(
27		#' x = data_logical,
28		#' varname = "variable",
29		#' varlabel = "label"
30		#' )
31		#' filter_state_logical$set_state(list(selected = FALSE, keep_na = TRUE))
32		#'
33		#' ui <- fluidPage(
34		#' column(4, div(
35		#' h4("LogicalFilterState"),
36		#' isolate(filter_state_logical$ui("fs"))
37		#' )),
38		#' column(4, div(
39		#' id = "outputs", # div id is needed for toggling the element
40		#' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
41		#' textOutput("condition_logical"), br(),
42		#' h4("Unformatted state"), # display raw filter state
43		#' textOutput("unformatted_logical"), br(),
44		#' h4("Formatted state"), # display human readable filter state
45		#' textOutput("formatted_logical"), br()
46		#' )),
47		#' column(4, div(
48		#' h4("Programmatic filter control"),
49		#' actionButton("button1_logical", "set drop NA", width = "100%"), br(),
50		#' actionButton("button2_logical", "set keep NA", width = "100%"), br(),
51		#' actionButton("button3_logical", "set a selection", width = "100%"), br(),
52		#' actionButton("button0_logical", "set initial state", width = "100%"), br()
53		#' ))
54		#' )
55		#'
56		#' server <- function(input, output, session) {
57		#' filter_state_logical$server("fs")
58		#' output$condition_logical <- renderPrint(filter_state_logical$get_call())
59		#' output$formatted_logical <- renderText(filter_state_logical$format())
60		#' output$unformatted_logical <- renderPrint(filter_state_logical$get_state())
61		#' # modify filter state programmatically
62		#' observeEvent(input$button1_logical, filter_state_logical$set_keep_na(FALSE))
63		#' observeEvent(input$button2_logical, filter_state_logical$set_keep_na(TRUE))
64		#' observeEvent(input$button3_logical, filter_state_logical$set_selected(TRUE))
65		#' observeEvent(
66		#' input$button0_logical,
67		#' filter_state_logical$set_state(list(selected = FALSE, keep_na = TRUE))
68		#' )
69		#' }
70		#'
71		#' if (interactive()) {
72		#' shinyApp(ui, server)
73		#' }
74		#' }
75		#'
76		LogicalFilterState <- R6::R6Class( # nolint
77		"LogicalFilterState",
78		inherit = FilterState,
79
80		# public methods ----
81		public = list(
82
83		#' @description
84		#' Initialize a `FilterState` object
85		#' @param x (`logical`)\cr
86		#' values of the variable used in filter
87		#' @param varname (`character`, `name`)\cr
88		#' label of the variable (optional).
89		#' @param varlabel (`character(1)`)\cr
90		#' label of the variable (optional).
91		#' @param dataname (`character(1)`)\cr
92		#' optional name of dataset where `x` is taken from
93		#' @param extract_type (`character(0)`, `character(1)`)\cr
94		#' whether condition calls should be prefixed by dataname. Possible values:
95		#' \itemize{
96		#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
97		#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
98		#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
99		#' }
100		initialize = function(x,
101		varname,
102		varlabel = character(0),
103		dataname = NULL,
104		extract_type = character(0)) {
105	16x	stopifnot(is.logical(x))
106	16x	super$initialize(x, varname, varlabel, dataname, extract_type)
107	16x	df <- as.factor(x)
108	16x	if (length(levels(df)) != 2) {
109	6x	if (levels(df) %in% c(TRUE, FALSE)) {
110	6x	choices_not_included <- c(TRUE, FALSE)[!c(TRUE, FALSE) %in% levels(df)]
111	6x	levels(df) <- c(levels(df), choices_not_included)
112		}
113		}
114
115	16x	tbl <- table(df)
116
117	16x	choices <- as.logical(names(tbl))
118	16x	names(choices) <- tbl
119	16x	private$set_choices(as.list(choices))
120	16x	self$set_selected(unname(choices)[1])
121	16x	private$histogram_data <- data.frame(
122	16x	x = sprintf(
123	16x	"%s (%s)",
124	16x	choices,
125	16x	names(choices)
126		),
127	16x	y = as.vector(tbl)
128		)
129
130	16x	invisible(self)
131		},
132
133		#' @description
134		#' Answers the question of whether the current settings and values selected actually filters out any values.
135		#' @return logical scalar
136		is_any_filtered = function() {
137	20x	if (!isTRUE(self$get_keep_na()) && private$na_count > 0) {
138	9x	TRUE
139	11x	} else if (all(private$histogram_data$y > 0)) {
140	6x	TRUE
141	5x	} else if (self$get_selected() == FALSE && "FALSE (0)" %in% private$histogram_data$x) {
142	1x	TRUE
143	4x	} else if (self$get_selected() == TRUE && "TRUE (0)" %in% private$histogram_data$x) {
144	1x	TRUE
145		} else {
146	3x	FALSE
147		}
148		},
149
150		#' @description
151		#' Returns reproducible condition call for current selection.
152		#' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally
153		#' `is.na(<varname>)`
154		get_call = function() {
155	8x	filter_call <-
156	8x	if (self$get_selected()) {
157	2x	private$get_varname_prefixed()
158		} else {
159	6x	call("!", private$get_varname_prefixed())
160		}
161	8x	private$add_keep_na_call(filter_call)
162		},
163
164		#' @description
165		#' Sets the selected values of this `LogicalFilterState`.
166		#'
167		#' @param value (`logical(1)`)\cr
168		#' the value to set. Must not contain the NA value.
169		#'
170		#' @returns invisibly `NULL`.
171		#'
172		#' @note Casts the passed object to `logical` before validating the input
173		#' making it possible to pass any object coercible to `logical` to this method.
174		#'
175		#' @examples
176		#' filter <- teal.slice:::LogicalFilterState$new(c(TRUE), varname = "name")
177		#' filter$set_selected(TRUE)
178		set_selected = function(value) {
179	44x	super$set_selected(value)
180		}
181		),
182
183		# private fields ----
184
185		private = list(
186		histogram_data = data.frame(),
187
188		# private methods ----
189
190		validate_selection = function(value) {
191	44x	if (!(checkmate::test_logical(value, max.len = 1, any.missing = FALSE))) {
192	2x	stop(
193	2x	sprintf(
194	2x	"value of the selection for `%s` in `%s` should be a logical scalar (TRUE or FALSE)",
195	2x	self$get_varname(),
196	2x	self$get_dataname()
197		)
198		)
199		}
200
201	42x	pre_msg <- sprintf(
202	42x	"dataset '%s', variable '%s': ",
203	42x	self$get_dataname(),
204	42x	self$get_varname()
205		)
206	42x	check_in_subset(value, private$choices, pre_msg = pre_msg)
207		},
208		cast_and_validate = function(values) {
209	44x	tryCatch(
210	44x	expr = {
211	44x	values_logical <- as.logical(values)
212	!	if (any(is.na(values_logical))) stop()
213		},
214	44x	error = function(cond) stop("The array of set values must contain values coercible to logical.")
215		)
216	44x	values_logical
217		},
218
219		# shiny modules ----
220
221		# @description
222		# UI Module for `EmptyFilterState`.
223		# This UI element contains available choices selection and
224		# checkbox whether to keep or not keep the `NA` values.
225		# @param id (`character(1)`)\cr
226		# id of shiny element
227		ui_inputs = function(id) {
228	!	ns <- NS(id)
229	!	l_counts <- as.numeric(names(private$choices))
230	!	l_counts[is.na(l_counts)] <- 0
231	!	l_freqs <- l_counts / sum(l_counts)
232	!	labels <- lapply(seq_along(private$choices), function(i) {
233	!	div(
234	!	class = "choices_state_label",
235	!	style = sprintf("width:%s%%", l_freqs[i] * 100),
236	!	span(
237	!	class = "choices_state_label_text",
238	!	sprintf(
239	!	"%s (%s)",
240	!	private$choices[i],
241	!	l_counts[i]
242		)
243		)
244		)
245		})
246	!	div(
247	!	div(
248	!	class = "choices_state",
249	!	radioButtons(
250	!	ns("selection"),
251	!	label = NULL,
252	!	choiceNames = labels,
253	!	choiceValues = as.character(private$choices),
254	!	selected = as.character(self$get_selected()),
255	!	width = "100%"
256		)
257		),
258	!	private$keep_na_ui(ns("keep_na"))
259		)
260		},
261
262		# @description
263		# Server module
264		#
265		# @param id (`character(1)`)\cr
266		# an ID string that corresponds with the ID used to call the module's UI function.
267		# @return `moduleServer` function which returns `NULL`
268		server_inputs = function(id) {
269	!	moduleServer(
270	!	id = id,
271	!	function(input, output, session) {
272		# this observer is needed in the situation when private$selected has been
273		# changed directly by the api - then it's needed to rerender UI element
274		# to show relevant values
275	!	private$observers$seleted_api <- observeEvent(
276	!	ignoreNULL = TRUE, # this is radio button so something have to be selected
277	!	ignoreInit = TRUE,
278	!	eventExpr = self$get_selected(),
279	!	handlerExpr = {
280	!	if (!setequal(self$get_selected(), input$selection)) {
281	!	updateRadioButtons(
282	!	session = session,
283	!	inputId = "selection",
284	!	selected = self$get_selected()
285		)
286	!	logger::log_trace(sprintf(
287	!	"LogicalFilterState$server@1 selection of variable %s changed, dataname: %s",
288	!	private$varname,
289	!	private$dataname
290		))
291		}
292		}
293		)
294
295	!	private$observers$selection <- observeEvent(
296	!	ignoreNULL = TRUE, # in radio button something has to be selected to input$selection can't be NULL
297	!	ignoreInit = TRUE,
298	!	eventExpr = input$selection,
299	!	handlerExpr = {
300	!	selection_state <- as.logical(input$selection)
301	!	if (is.null(selection_state)) {
302	!	selection_state <- logical(0)
303		}
304	!	self$set_selected(selection_state)
305	!	logger::log_trace(
306	!	sprintf(
307	!	"LogicalFilterState$server@2 selection of variable %s changed, dataname: %s",
308	!	private$varname,
309	!	private$dataname
310		)
311		)
312		}
313		)
314
315	!	private$keep_na_srv("keep_na")
316
317	!	logger::log_trace("LogicalFilterState$server initialized, dataname: { private$dataname }")
318	!	NULL
319		}
320		)
321		}
322		)
323		)

1		#' @name FilterPanelAPI
2		#' @docType class
3		#'
4		#' @title Class to encapsulate the API of the filter panel of a teal app
5		#'
6		#' @details
7		#' The purpose of this class is to encapsulate the API of the filter panel in a new class `FilterPanelAPI` so
8		#' that it can be passed and used in the `server` call of any module instead of passing the whole `FilteredData`
9		#' object.
10		#'
11		#' This class is supported by methods to set, get, remove filter states in the filter panel API.
12		#'
13		#' @export
14		#'
15		#' @examples
16		#' library(teal.slice)
17		#' fd <- teal.slice::init_filtered_data(list(iris = list(dataset = iris)))
18		#' fpa <- FilterPanelAPI$new(fd)
19		#'
20		#' # get the actual filter state --> empty named list
21		#' isolate(fpa$get_filter_state())
22		#'
23		#' # set a filter state
24		#' isolate(
25		#' set_filter_state(
26		#' fpa,
27		#' list(iris = list(Species = list(selected = "setosa", keep_na = TRUE)))
28		#' )
29		#' )
30		#'
31		#' # get the actual filter state --> named list with filters
32		#' isolate(fpa$get_filter_state())
33		#'
34		#' # remove all_filter_states
35		#' fpa$remove_all_filter_states()
36		#'
37		#' # get the actual filter state --> empty named list
38		#' isolate(fpa$get_filter_state())
39		#'
40		FilterPanelAPI <- R6::R6Class( # nolint
41		"FilterPanelAPI",
42		## __Public Methods ====
43		public = list(
44		#' @description
45		#' Initialize a `FilterPanelAPI` object
46		#' @param datasets (`FilteredData`) object.
47		initialize = function(datasets) {
48	10x	checkmate::assert_class(datasets, "FilteredData")
49	8x	private$filtered_data <- datasets
50		},
51
52		#' @description
53		#' Gets the reactive values from the active `FilterState` objects of the `FilteredData` object.
54		#'
55		#' Gets all active filters in the form of a nested list.
56		#' The output list is a compatible input to `set_filter_state`.
57		#'
58		#' @return `list` with named elements corresponding to `FilteredDataset` objects with active filters.
59		get_filter_state = function() {
60	7x	private$filtered_data$get_filter_state()
61		},
62
63		#' @description
64		#' Sets active filter states.
65		#' @param filter (`named list`)\cr
66		#' nested list of filter selections applied to datasets.
67		#'
68		#' @return `NULL`
69		set_filter_state = function(filter) {
70	8x	if (private$filtered_data$get_filter_panel_active()) {
71	6x	private$filtered_data$set_filter_state(filter)
72		} else {
73	2x	warning(private$deactivated_msg)
74		}
75	8x	invisible(NULL)
76		},
77
78		#' @description
79		#' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object.
80		#' @param filter (`named list`)\cr
81		#' nested list of filter selections applied to datasets.
82		#'
83		#' @return `NULL`
84		remove_filter_state = function(filter) {
85	1x	if (private$filtered_data$get_filter_panel_active()) {
86	1x	private$filtered_data$remove_filter_state(filter)
87		} else {
88	!	warning(private$deactivated_msg)
89		}
90	1x	invisible(NULL)
91		},
92
93		#' @description Remove all `FilterStates` of the `FilteredData` object.
94		#'
95		#' @param datanames (`character`)\cr
96		#' datanames to remove their `FilterStates`;
97		#' omit to remove all `FilterStates` in the `FilteredData` object
98		#'
99		#' @return `NULL`
100		#'
101		remove_all_filter_states = function(datanames) {
102	5x	if (private$filtered_data$get_filter_panel_active()) {
103	3x	datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames
104	3x	private$filtered_data$remove_all_filter_states(datanames = datanames_to_remove)
105		} else {
106	2x	warning(private$deactivated_msg)
107		}
108	5x	invisible(NULL)
109		},
110		#' @description
111		#' Toggle the state of the global Filter Panel button by running `javascript` code
112		#' to click the toggle button with the `filter_panel_active` id suffix.
113		#' The button id is prefixed with the Filter Panel shiny namespace.
114		#' This button is observed in `srv_filter_panel` method that executes
115		#' `filter_panel_enable()` or `filter_panel_disable()` method depending on the toggle state.
116		#'
117		#' @return `NULL`
118		filter_panel_toggle = function() {
119	!	shinyjs::runjs(
120	!	sprintf(
121	!	'$("#%s-filter_turn_onoff").click();',
122	!	private$filtered_data$get_filter_panel_ui_id()
123		)
124		)
125	!	invisible(NULL)
126		}
127		),
128		## __Private Methods ====
129		private = list(
130		filtered_data = NULL,
131		deactivated_msg = "Filter Panel is deactivated so the action can not be applied with api."
132		)
133		)

1		# MAEFilteredDataset ------
2		#' @keywords internal
3		#' @title `MAEFilteredDataset` R6 class
4		MAEFilteredDataset <- R6::R6Class( # nolint
5		classname = "MAEFilteredDataset",
6		inherit = FilteredDataset,
7
8		# public methods ----
9		public = list(
10
11		#' @description
12		#' Initialize `MAEFilteredDataset` object
13		#'
14		#' @param dataset (`MulitiAssayExperiment`)\cr
15		#' a single `MultiAssayExperiment` for which to define a subset
16		#' @param dataname (`character`)\cr
17		#' a given name for the dataset it may not contain spaces
18		#' @param keys optional, (`character`)\cr
19		#' vector with primary keys
20		#' @param label (`character`)\cr
21		#' label to describe the dataset
22		#' @param metadata (named `list` or `NULL`) \cr
23		#' field containing metadata about the dataset;
24		#' each element of the list must be atomic and length one
25		#'
26		initialize = function(dataset, dataname, keys = character(0), label = character(0), metadata = NULL) {
27	28x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
28	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
29		}
30	28x	checkmate::assert_class(dataset, "MultiAssayExperiment")
31	27x	super$initialize(dataset, dataname, keys, label, metadata)
32	27x	experiment_names <- names(dataset)
33
34		# subsetting by subjects means subsetting by colData(MAE)
35	27x	private$add_filter_states(
36	27x	filter_states = init_filter_states(
37	27x	data = dataset,
38	27x	dataname = dataname,
39	27x	varlabels = self$get_varlabels(),
40	27x	datalabel = "subjects",
41	27x	keys = self$get_keys()
42		),
43	27x	id = "subjects"
44		)
45		# elements of the list (experiments) are unknown
46		# dispatch needed because we can't hardcode methods otherwise:
47		# if (matrix) else if (SummarizedExperiment) else if ...
48	27x	lapply(
49	27x	experiment_names,
50	27x	function(experiment_name) {
51	135x	private$add_filter_states(
52	135x	filter_states = init_filter_states(
53	135x	data = dataset[[experiment_name]],
54	135x	dataname = sprintf('%s[["%s"]]', dataname, experiment_name),
55	135x	datalabel = experiment_name
56		),
57	135x	id = experiment_name
58		)
59		}
60		)
61		},
62
63		#' @description
64		#' Get filter expression
65		#'
66		#' This functions returns filter calls equivalent to selected items
67		#' within each of `filter_states`. Configuration of the calls is constant and
68		#' depends on `filter_states` type and order which are set during initialization.
69		#' This class contains multiple `FilterStates`:
70		#' \itemize{
71		#' \item{`colData(dataset)`}{for this object single `MAEFilterStates`
72		#' which returns `subsetByColData` call}
73		#' \item{experiments}{for each experiment single `SEFilterStates` and
74		#' `FilterStates_matrix`, both returns `subset` call}
75		#' }
76		#' @return filter `call` or `list` of filter calls
77		get_call = function() {
78	10x	filter_call <- Filter(
79	10x	f = Negate(is.null),
80	10x	x = lapply(
81	10x	self$get_filter_states(),
82	10x	function(x) x$get_call()
83		)
84		)
85	10x	if (length(filter_call) == 0) {
86	5x	return(NULL)
87		}
88	5x	filter_call
89		},
90
91		#' @description
92		#' Gets labels of variables in the data
93		#'
94		#' Variables are the column names of the data.
95		#' Either, all labels must have been provided for all variables
96		#' in `set_data` or `NULL`.
97		#'
98		#' @param variables (`character` vector) variables to get labels for;
99		#' if `NULL`, for all variables in data
100		#' @return (`character` or `NULL`) variable labels, `NULL` if `column_labels`
101		#' attribute does not exist for the data
102		get_varlabels = function(variables = NULL) {
103	28x	checkmate::assert_character(variables, null.ok = TRUE, any.missing = FALSE)
104
105	28x	labels <- vapply(
106	28x	X = SummarizedExperiment::colData(private$dataset),
107	28x	FUN.VALUE = character(1),
108	28x	FUN = function(x) {
109	840x	label <- attr(x, "label")
110	840x	if (length(label) != 1) {
111	28x	NA_character_
112		} else {
113	2x	label
114		}
115		}
116		)
117
118	28x	if (is.null(labels)) {
119	!	return(NULL)
120		}
121	1x	if (!is.null(variables)) labels <- labels[names(labels) %in% variables]
122	28x	labels
123		},
124
125		#' @description
126		#' Get filter overview rows of a dataset
127		#' @param filtered_dataset (`MultiAssayExperiment`) object to calculate filter overview statistics on.
128		#' @return (`matrix`) matrix of observations and subjects
129		get_filter_overview_info = function(filtered_dataset = self$get_dataset()) {
130	6x	names_exps <- paste0("- ", names(self$get_dataset()))
131	6x	mae_and_exps <- c(self$get_dataname(), names_exps)
132
133	6x	df <- cbind(
134	6x	private$get_filter_overview_nobs(filtered_dataset),
135	6x	self$get_filter_overview_nsubjs(filtered_dataset)
136		)
137
138	6x	rownames(df) <- mae_and_exps
139	6x	colnames(df) <- c("Obs", "Subjects")
140
141	6x	df
142		},
143
144		#' @description
145		#' Gets variable names for the filtering.
146		#'
147		#' @return (`character(0)`)
148		get_filterable_varnames = function() {
149	1x	character(0)
150		},
151
152		#' @description
153		#' Set filter state
154		#'
155		#' @param state (`named list`)\cr
156		#' names of the list should correspond to the names of the initialized `FilterStates`
157		#' kept in `private$filter_states`. For this object they are `"subjects"` and
158		#' names of the experiments. Values of initial state should be relevant
159		#' to the referred column.
160		#' @param ... ignored.
161		#' @examples
162		#' utils::data(miniACC, package = "MultiAssayExperiment")
163		#' dataset <- teal.slice:::MAEFilteredDataset$new(miniACC, "MAE")
164		#' fs <- list(
165		#' subjects = list(
166		#' years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE),
167		#' vital_status = list(selected = "1", keep_na = FALSE),
168		#' gender = list(selected = "female", keep_na = TRUE)
169		#' ),
170		#' RPPAArray = list(
171		#' subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE))
172		#' )
173		#' )
174		#' shiny::isolate(dataset$set_filter_state(state = fs))
175		#' shiny::isolate(dataset$get_filter_state())
176		#' @return `NULL`
177		set_filter_state = function(state, ...) {
178	11x	checkmate::assert_list(state)
179	10x	checkmate::assert_subset(names(state), c(names(self$get_filter_states())))
180
181	9x	logger::log_trace(
182	9x	sprintf(
183	9x	"MAEFilteredDataset$set_filter_state setting up filters of variable %s, dataname: %s",
184	9x	paste(names(state), collapse = ", "),
185	9x	self$get_dataname()
186		)
187		)
188	9x	data <- self$get_dataset()
189	9x	for (fs_name in names(state)) {
190	17x	fs <- self$get_filter_states()[[fs_name]]
191	17x	fs$set_filter_state(
192	17x	state = state[[fs_name]],
193	17x	data = `if`(fs_name == "subjects", data, data[[fs_name]])
194		)
195		}
196
197	8x	logger::log_trace(
198	8x	sprintf(
199	8x	"MAEFilteredDataset$set_filter_state done setting filters of variable %s, dataname: %s",
200	8x	paste(names(state), collapse = ", "),
201	8x	self$get_dataname()
202		)
203		)
204	8x	NULL
205		},
206
207		#' @description Remove one or more `FilterState` of a `MAEFilteredDataset`
208		#'
209		#' @param state_id (`list`)\cr
210		#' Named list of variables to remove their `FilterState`.
211		#'
212		#' @return `NULL`
213		#'
214		remove_filter_state = function(state_id) {
215	2x	checkmate::assert_list(state_id, names = "unique")
216	1x	checkmate::assert_subset(names(state_id), c(names(self$get_filter_states())))
217
218	1x	logger::log_trace(
219	1x	sprintf(
220	1x	"MAEFilteredDataset$remove_filter_state removing filters of variable %s, dataname: %s",
221	1x	state_id,
222	1x	self$get_dataname()
223		)
224		)
225
226	1x	for (fs_name in names(state_id)) {
227	1x	fdata_filter_state <- self$get_filter_states()[[fs_name]]
228	1x	fdata_filter_state$remove_filter_state(
229	1x	`if`(fs_name == "subjects", state_id[[fs_name]][[1]], state_id[[fs_name]])
230		)
231		}
232	1x	logger::log_trace(
233	1x	sprintf(
234	1x	"MAEFilteredDataset$remove_filter_state done removing filters of variable %s, dataname: %s",
235	1x	state_id,
236	1x	self$get_dataname()
237		)
238		)
239	1x	invisible(NULL)
240		},
241
242		#' @description
243		#' UI module to add filter variable for this dataset
244		#'
245		#' UI module to add filter variable for this dataset
246		#' @param id (`character(1)`)\cr
247		#' identifier of the element - preferably containing dataset name
248		#'
249		#' @return function - shiny UI module
250		ui_add_filter_state = function(id) {
251	!	ns <- NS(id)
252	!	data <- self$get_dataset()
253	!	experiment_names <- names(data)
254
255	!	div(
256	!	tags$label("Add", tags$code(self$get_dataname()), "filter"),
257	!	br(),
258	!	HTML("►"),
259	!	tags$label("Add subjects filter"),
260	!	self$get_filter_states("subjects")$ui_add_filter_state(
261	!	id = ns("subjects"),
262	!	data = data
263		),
264	!	tagList(
265	!	lapply(
266	!	experiment_names,
267	!	function(experiment_name) {
268	!	tagList(
269	!	HTML("►"),
270	!	tags$label("Add", tags$code(experiment_name), "filter"),
271	!	self$get_filter_states(experiment_name)$ui_add_filter_state(
272	!	id = ns(experiment_name),
273	!	data = data[[experiment_name]]
274		)
275		)
276		}
277		)
278		)
279		)
280		},
281
282		#' @description
283		#' Server module to add filter variable for this dataset
284		#'
285		#' Server module to add filter variable for this dataset.
286		#' For this class `srv_add_filter_state` calls multiple modules
287		#' of the same name from `FilterStates` as `MAEFilteredDataset`
288		#' contains one `FilterStates` object for `colData` and one for each
289		#' experiment.
290		#'
291		#' @param id (`character(1)`)\cr
292		#' an ID string that corresponds with the ID used to call the module's UI function.
293		#' @param ... ignored.
294		#' @return `moduleServer` function which returns `NULL`
295		srv_add_filter_state = function(id, ...) {
296	!	moduleServer(
297	!	id = id,
298	!	function(input, output, session) {
299	!	logger::log_trace(paste(
300	!	"MAEFilteredDataset$srv_add_filter_state initializing,",
301	!	"dataname: { deparse1(self$get_dataname()) }"
302		))
303	!	data <- self$get_dataset()
304	!	self$get_filter_states("subjects")$srv_add_filter_state(
305	!	id = "subjects",
306	!	data = data # MultiAssayExperiment
307		# ignoring vars_include
308		)
309
310	!	experiment_names <- names(data)
311	!	lapply(
312	!	experiment_names,
313	!	function(experiment_name) {
314	!	self$get_filter_states(experiment_name)$srv_add_filter_state(
315	!	id = experiment_name,
316	!	data = data[[experiment_name]] # SummarizedExperiment or matrix
317		# ignoring vars_include
318		)
319		}
320		)
321	!	logger::log_trace(paste(
322	!	"MAEFilteredDataset$srv_add_filter_state initialized,",
323	!	"dataname: { deparse1(self$get_dataname()) }"
324		))
325	!	NULL
326		}
327		)
328		},
329
330		#' @description
331		#' Gets filter overview subjects number
332		#' @param filtered_dataset (`MultiAssayExperiment`) object to calculate filter overview statistics on.
333		#' @param subject_keys (unused) in `MultiAssayExperiment` unique subjects are the rows of `colData` slot.
334		#' @return `list` with the number of subjects of filtered/non-filtered datasets.
335		get_filter_overview_nsubjs = function(filtered_dataset = self$get_dataset(), subject_keys) {
336	10x	data_f <- filtered_dataset
337	10x	data_nf <- self$get_dataset()
338	10x	experiment_names <- names(data_nf)
339
340	10x	data_f_subjects_info <- nrow(SummarizedExperiment::colData(data_f))
341	10x	data_nf_subjects_info <- nrow(SummarizedExperiment::colData(data_nf))
342	10x	mae_total_subjects_info <- paste0(data_f_subjects_info, "/", data_nf_subjects_info)
343
344	10x	get_experiment_rows <- function(mae, experiment) {
345	100x	sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment))
346	100x	length(unique(sample_subset$primary))
347		}
348
349	10x	subjects_info <- lapply(
350	10x	experiment_names,
351	10x	function(experiment_name) {
352	50x	subjects_f_rows <- get_experiment_rows(data_f, data_f[[experiment_name]])
353	50x	subjects_nf_rows <- get_experiment_rows(data_nf, data_nf[[experiment_name]])
354
355	50x	subjects_info <- paste0(subjects_f_rows, "/", subjects_nf_rows)
356	50x	subjects_info
357		}
358		)
359
360	10x	append(
361	10x	list(mae_total_subjects_info),
362	10x	subjects_info
363		)
364		}
365		),
366
367		# private members ----
368		private = list(
369
370		# Gets filter overview observations number and returns a
371		# list of the number of observations of filtered/non-filtered datasets
372		get_filter_overview_nobs = function(filtered_dataset) {
373	6x	data_f <- filtered_dataset
374	6x	data_nf <- self$get_dataset()
375	6x	experiment_names <- names(data_nf)
376	6x	mae_total_data_info <- ""
377
378	6x	data_info <- lapply(
379	6x	experiment_names,
380	6x	function(experiment_name) {
381	30x	data_f_rows <- ncol(data_f[[experiment_name]])
382	30x	data_nf_rows <- ncol(data_nf[[experiment_name]])
383
384	30x	data_info <- paste0(data_f_rows, "/", data_nf_rows)
385	30x	data_info
386		}
387		)
388
389	6x	append(
390	6x	list(mae_total_data_info),
391	6x	data_info
392		)
393		}
394		)
395		)

1		#' @name EmptyFilterState
2		#' @title `FilterState` object for empty variable
3		#' @description `FilterState` subclass representing an empty variable
4		#' @docType class
5		#' @keywords internal
6		#'
7		#'
8		#' @examples
9		#' filter_state <- teal.slice:::EmptyFilterState$new(
10		#' NA,
11		#' varname = "x",
12		#' dataname = "data",
13		#' extract_type = character(0)
14		#' )
15		#' isolate(filter_state$get_call())
16		#' isolate(filter_state$set_selected(TRUE))
17		#' isolate(filter_state$set_keep_na(TRUE))
18		#' isolate(filter_state$get_call())
19		#'
20		EmptyFilterState <- R6::R6Class( # nolint
21		"EmptyFilterState",
22		inherit = FilterState,
23
24		# public methods ----
25		public = list(
26		#' @description
27		#' Initialize `EmptyFilterState` object.
28		#'
29		#' @param x (`vector`)\cr
30		#' values of the variable used in filter
31		#' @param varname (`character`, `name`)\cr
32		#' name of the variable
33		#' @param varlabel (`character(1)`)\cr
34		#' label of the variable (optional).
35		#' @param dataname (`character(1)`)\cr
36		#' optional name of dataset where `x` is taken from
37		#' @param extract_type (`character(0)`, `character(1)`)\cr
38		#' whether condition calls should be prefixed by dataname. Possible values:
39		#' \itemize{
40		#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
41		#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
42		#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
43		#' }
44		#'
45		initialize = function(x,
46		varname,
47		varlabel = character(0),
48		dataname = NULL,
49		extract_type = character(0)) {
50	6x	super$initialize(x, varname, varlabel, dataname, extract_type)
51	6x	private$set_choices(list())
52	6x	self$set_selected(list())
53
54	6x	return(invisible(self))
55		},
56
57		#' @description
58		#' Reports whether the current state filters out any values.(?)
59		#'
60		#' @return `logical(1)`
61		#'
62		is_any_filtered = function() {
63	2x	!isTRUE(self$get_keep_na())
64		},
65
66		#' @description
67		#' Returns reproducible condition call for current selection relevant
68		#' for selected variable type.
69		#' Uses internal reactive values, hence must be called
70		#' in reactive or isolated context.
71		#'
72		#' @return `logical(1)`
73		#'
74		get_call = function() {
75	2x	filter_call <- if (isTRUE(self$get_keep_na())) {
76	1x	call("is.na", private$get_varname_prefixed())
77		} else {
78	1x	FALSE
79		}
80		},
81
82		#' @description
83		#' Returns the filtering state.
84		#'
85		#' @return `list` containing values taken from the reactive fields:
86		#' * `keep_na` (`logical(1)`) whether `NA` should be kept.
87		#'
88		get_state = function() {
89	1x	list(
90	1x	keep_na = self$get_keep_na()
91		)
92		},
93
94		#' @description
95		#' Set state.
96		#'
97		#' @param state (`list`)\cr
98		#' contains fields relevant for specific class:
99		#' \itemize{
100		#' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
101		#' }
102		#'
103		#' @return NULL invisibly
104		set_state = function(state) {
105	4x	if (!is.null(state$selected)) {
106	1x	stop(
107	1x	sprintf(
108	1x	"All values in variable '%s' are `NA`. Unable to apply filter values \n %s",
109	1x	private$varname,
110	1x	paste(state$selected, collapse = ", ")
111		)
112		)
113		}
114	3x	stopifnot(is.list(state) && all(names(state) == "keep_na"))
115	2x	if (!is.null(state$keep_na)) {
116	2x	self$set_keep_na(state$keep_na)
117		}
118	2x	invisible(NULL)
119		}
120		),
121
122		# private members ----
123		private = list(
124		# @description
125		# UI Module for `EmptyFilterState`.
126		# This UI element contains a checkbox input to filter or keep missing values.
127		#
128		# @param id (`character(1)`)\cr
129		# shiny element (module instance) id
130		#
131		ui_inputs = function(id) {
132	!	ns <- NS(id)
133	!	fluidRow(
134	!	div(
135	!	class = "relative",
136	!	div(
137	!	span("Variable contains missing values only"),
138	!	private$keep_na_ui(ns("keep_na"))
139		)
140		)
141		)
142		},
143
144		# @description
145		# Controls state of the `keep_na` checkbox input.
146		#
147		# @param id (`character(1)`)\cr
148		# shiny module instance id
149		#
150		# @return `moduleServer` function which returns `NULL`
151		#
152		server_inputs = function(id) {
153	!	moduleServer(
154	!	id = id,
155	!	function(input, output, session) {
156	!	private$keep_na_srv("keep_na")
157		}
158		)
159		}
160		)
161		)

1		#' @name DateFilterState
2		#' @title `FilterState` object for Date variable
3		#' @description Manages choosing a range of Dates
4		#' @docType class
5		#' @keywords internal
6		#'
7		#'
8		#' @examples
9		#' filter_state <- teal.slice:::DateFilterState$new(
10		#' c(Sys.Date() + seq(1:10), NA),
11		#' varname = "x",
12		#' dataname = "data",
13		#' extract_type = character(0)
14		#' )
15		#' isolate(filter_state$get_call())
16		#'
17		#' isolate(filter_state$set_selected(c(Sys.Date() + 3L, Sys.Date() + 8L)))
18		#' isolate(filter_state$set_keep_na(TRUE))
19		#' isolate(filter_state$get_call())
20		#'
21		#' \dontrun{
22		#' # working filter in an app
23		#' library(shiny)
24		#'
25		#' dates <- c(Sys.Date() - 100, Sys.Date())
26		#' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA)
27		#' filter_state_date <- DateFilterState$new(
28		#' x = data_date,
29		#' varname = "variable",
30		#' varlabel = "label"
31		#' )
32		#' filter_state_date$set_state(list(selected = data_date[c(47, 98)], keep_na = TRUE))
33		#'
34		#' ui <- fluidPage(
35		#' column(4, div(
36		#' h4("DateFilterState"),
37		#' isolate(filter_state_date$ui("fs"))
38		#' )),
39		#' column(4, div(
40		#' id = "outputs", # div id is needed for toggling the element
41		#' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
42		#' textOutput("condition_date"), br(),
43		#' h4("Unformatted state"), # display raw filter state
44		#' textOutput("unformatted_date"), br(),
45		#' h4("Formatted state"), # display human readable filter state
46		#' textOutput("formatted_date"), br()
47		#' )),
48		#' column(4, div(
49		#' h4("Programmatic filter control"),
50		#' actionButton("button1_date", "set drop NA", width = "100%"), br(),
51		#' actionButton("button2_date", "set keep NA", width = "100%"), br(),
52		#' actionButton("button3_date", "set a range", width = "100%"), br(),
53		#' actionButton("button4_date", "set full range", width = "100%"), br(),
54		#' actionButton("button0_date", "set initial state", width = "100%"), br()
55		#' ))
56		#' )
57		#'
58		#' server <- function(input, output, session) {
59		#' filter_state_date$server("fs")
60		#' output$condition_date <- renderPrint(filter_state_date$get_call())
61		#' output$formatted_date <- renderText(filter_state_date$format())
62		#' output$unformatted_date <- renderPrint(filter_state_date$get_state())
63		#' # modify filter state programmatically
64		#' observeEvent(input$button1_date, filter_state_date$set_keep_na(FALSE))
65		#' observeEvent(input$button2_date, filter_state_date$set_keep_na(TRUE))
66		#' observeEvent(
67		#' input$button3_date,
68		#' filter_state_date$set_selected(data_date[c(34, 56)])
69		#' )
70		#' observeEvent(input$button4_date, filter_state_date$set_selected(dates))
71		#' observeEvent(
72		#' input$button0_date,
73		#' filter_state_date$set_state(list(selected = data_date[c(47, 98)], keep_na = TRUE))
74		#' )
75		#' }
76		#'
77		#' if (interactive()) {
78		#' shinyApp(ui, server)
79		#' }
80		#' }
81		#'
82		DateFilterState <- R6::R6Class( # nolint
83		"DateFilterState",
84		inherit = FilterState,
85
86		# public methods ----
87
88		public = list(
89
90		#' @description
91		#' Initialize a `FilterState` object
92		#' @param x (`Date`)\cr
93		#' values of the variable used in filter
94		#' @param varname (`character`, `name`)\cr
95		#' name of the variable
96		#' @param varlabel (`character(1)`)\cr
97		#' label of the variable (optional).
98		#' @param dataname (`character(1)`)\cr
99		#' optional name of dataset where `x` is taken from
100		#' @param extract_type (`character(0)`, `character(1)`)\cr
101		#' whether condition calls should be prefixed by dataname. Possible values:
102		#' \itemize{
103		#' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
104		#' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
105		#' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
106		#' }
107		initialize = function(x,
108		varname,
109		varlabel = character(0),
110		dataname = NULL,
111		extract_type = character(0)) {
112	20x	stopifnot(is(x, "Date"))
113	20x	super$initialize(x, varname, varlabel, dataname, extract_type)
114
115	20x	var_range <- range(x, na.rm = TRUE)
116	20x	private$set_choices(var_range)
117	20x	self$set_selected(var_range)
118
119	20x	return(invisible(self))
120		},
121
122		#' @description
123		#' Returns a formatted string representing this `DateFilterState`.
124		#'
125		#' @param indent (`numeric(1)`) the number of spaces before after each new line character of the formatted string.
126		#' Default: 0
127		#' @return `character(1)` the formatted string
128		#'
129		format = function(indent = 0) {
130	6x	checkmate::assert_number(indent, finite = TRUE, lower = 0)
131
132	5x	vals <- self$get_selected()
133	5x	sprintf(
134	5x	"%sFiltering on: %s\n%1$s Selected range: %s - %s\n%1$s Include missing values: %s",
135	5x	format("", width = indent),
136	5x	private$varname,
137	5x	format(vals[1], nsmall = 3),
138	5x	format(vals[2], nsmall = 3),
139	5x	format(self$get_keep_na())
140		)
141		},
142
143		#' @description
144		#' Answers the question of whether the current settings and values selected actually filters out any values.
145		#' @return logical scalar
146		is_any_filtered = function() {
147	8x	if (!setequal(self$get_selected(), private$choices)) {
148	6x	TRUE
149	2x	} else if (!isTRUE(self$get_keep_na()) && private$na_count > 0) {
150	1x	TRUE
151		} else {
152	1x	FALSE
153		}
154		},
155
156		#' @description
157		#' Returns reproducible condition call for current selection.
158		#' For this class returned call looks like
159		#' `<varname> >= <min value> & <varname> <= <max value>` with
160		#' optional `is.na(<varname>)`.
161		#' @return (`call`)
162		get_call = function() {
163	9x	choices <- as.character(self$get_selected())
164	9x	filter_call <-
165	9x	call(
166		"&",
167	9x	call(">=", private$get_varname_prefixed(), call("as.Date", choices[1L])),
168	9x	call("<=", private$get_varname_prefixed(), call("as.Date", choices[2L]))
169		)
170	9x	private$add_keep_na_call(filter_call)
171		},
172
173		#' @description
174		#' Sets the selected time frame of this `DateFilterState`.
175		#'
176		#' @param value (`Date(2)`) the lower and the upper bound of the selected
177		#' time frame. Must not contain NA values.
178		#'
179		#' @return invisibly `NULL`.
180		#'
181		#' @note Casts the passed object to `Date` before validating the input
182		#' making it possible to pass any object coercible to `Date` to this method.
183		#'
184		#' @examples
185		#' date <- as.Date("13/09/2021")
186		#' filter <- teal.slice:::DateFilterState$new(
187		#' c(date, date + 1, date + 2, date + 3),
188		#' varname = "name"
189		#' )
190		#' filter$set_selected(c(date + 1, date + 2))
191		set_selected = function(value) {
192	42x	super$set_selected(value)
193		}
194		),
195
196		# private methods ----
197
198		private = list(
199		validate_selection = function(value) {
200	41x	if (!is(value, "Date")) {
201	!	stop(
202	!	sprintf(
203	!	"value of the selection for `%s` in `%s` should be a Date",
204	!	self$get_varname(),
205	!	self$get_dataname()
206		)
207		)
208		}
209	41x	pre_msg <- sprintf(
210	41x	"dataset '%s', variable '%s': ",
211	41x	self$get_dataname(),
212	41x	self$get_varname()
213		)
214	41x	check_in_range(value, private$choices, pre_msg = pre_msg)
215		},
216		cast_and_validate = function(values) {
217	42x	tryCatch(
218	42x	expr = {
219	42x	values <- as.Date(values)
220	!	if (any(is.na(values))) stop()
221		},
222	42x	error = function(error) stop("The array of set values must contain values coercible to Date.")
223		)
224	!	if (length(values) != 2) stop("The array of set values must have length two.")
225	41x	values
226		},
227		remove_out_of_bound_values = function(values) {
228	41x	if (values[1] < private$choices[1]) {
229	4x	warning(paste(
230	4x	"Value:", values[1], "is outside of the possible range for column", private$varname,
231	4x	"of dataset", private$dataname, "."
232		))
233	4x	values[1] <- private$choices[1]
234		}
235
236	41x	if (values[2] > private$choices[2]) {
237	4x	warning(paste(
238	4x	"Value:", values[2], "is outside of the possible range for column", private$varname,
239	4x	"of dataset", private$dataname, "."
240		))
241	4x	values[2] <- private$choices[2]
242		}
243	41x	values
244		},
245
246		# shiny modules ----
247
248		# @description
249		# UI Module for `DateFilterState`.
250		# This UI element contains two date selections for `min` and `max`
251		# of the range and a checkbox whether to keep the `NA` values.
252		# @param id (`character(1)`)\cr
253		# id of shiny element
254		ui_inputs = function(id) {
255	!	ns <- NS(id)
256	!	div(
257	!	div(
258	!	class = "flex",
259	!	actionButton(
260	!	class = "date_reset_button",
261	!	inputId = ns("start_date_reset"),
262	!	label = NULL,
263	!	icon = icon("fas fa-undo")
264		),
265	!	div(
266	!	class = "w-80 filter_datelike_input",
267	!	dateRangeInput(
268	!	inputId = ns("selection"),
269	!	label = NULL,
270	!	start = self$get_selected()[1],
271	!	end = self$get_selected()[2],
272	!	min = private$choices[1],
273	!	max = private$choices[2],
274	!	width = "100%"
275		)
276		),
277	!	actionButton(
278	!	class = "date_reset_button",
279	!	inputId = ns("end_date_reset"),
280	!	label = NULL,
281	!	icon = icon("fas fa-undo")
282		)
283		),
284	!	private$keep_na_ui(ns("keep_na"))
285		)
286		},
287
288		# @description
289		# Server module
290		# @param id (`character(1)`)\cr
291		# an ID string that corresponds with the ID used to call the module's UI function.
292		# @return `moduleServer` function which returns `NULL`
293		server_inputs = function(id) {
294	!	moduleServer(
295	!	id = id,
296	!	function(input, output, session) {
297	!	logger::log_trace("DateFilterState$server initializing, dataname: { private$dataname }")
298
299		# this observer is needed in the situation when private$selected has been
300		# changed directly by the api - then it's needed to rerender UI element
301		# to show relevant values
302	!	private$observers$seletion_api <- observeEvent(
303	!	ignoreNULL = TRUE, # dates needs to be selected
304	!	ignoreInit = TRUE,
305	!	eventExpr = self$get_selected(),
306	!	handlerExpr = {
307	!	if (!setequal(self$get_selected(), input$selection)) {
308	!	updateDateRangeInput(
309	!	session = session,
310	!	inputId = "selection",
311	!	start = self$get_selected()[1],
312	!	end = self$get_selected()[2]
313		)
314	!	logger::log_trace(sprintf(
315	!	"DateFilterState$server@1 selection of variable %s changed, dataname: %s",
316	!	private$varname,
317	!	private$dataname
318		))
319		}
320		}
321		)
322
323	!	private$observers$selection <- observeEvent(
324	!	ignoreNULL = TRUE, # dates needs to be selected
325	!	ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
326	!	eventExpr = input$selection,
327	!	handlerExpr = {
328	!	start_date <- input$selection[1]
329	!	end_date <- input$selection[2]
330
331	!	self$set_selected(c(start_date, end_date))
332	!	logger::log_trace(sprintf(
333	!	"DateFilterState$server@2 selection of variable %s changed, dataname: %s",
334	!	private$varname,
335	!	private$dataname
336		))
337		}
338		)
339
340
341	!	private$keep_na_srv("keep_na")
342
343	!	private$observers$reset1 <- observeEvent(input$start_date_reset, {
344	!	updateDateRangeInput(
345	!	session = session,
346	!	inputId = "selection",
347	!	start = private$choices[1]
348		)
349	!	logger::log_trace(sprintf(
350	!	"DateFilterState$server@3 reset start date of variable %s, dataname: %s",
351	!	private$varname,
352	!	private$dataname
353		))
354		})
355
356	!	private$observers$reset2 <- observeEvent(input$end_date_reset, {
357	!	updateDateRangeInput(
358	!	session = session,
359	!	inputId = "selection",
360	!	end = private$choices[2]
361		)
362	!	logger::log_trace(sprintf(
363	!	"DateFilterState$server@4 reset end date of variable %s, dataname: %s",
364	!	private$varname,
365	!	private$dataname
366		))
367		})
368	!	logger::log_trace("DateFilterState$server initialized, dataname: { private$dataname }")
369	!	NULL
370		}
371		)
372		}
373		)
374		)

1		#' Ensure the ellipsis, ..., in method arguments are empty
2		#'
3		#' Ellipsis, ..., are needed as part of method arguments to allow for its arguments to be different from its generic's
4		#' arguments and for this to pass check(). Hence, ..., should always be empty. This function will check for this
5		#' condition.
6		#'
7		#' @param ... it should literally just be ...
8		#' @param stop TRUE to raise an error; FALSE will output warning message
9		#' @param allowed_args character vector naming arguments that are allowed in the \code{...}.
10		#' to allow for unnamed arguments, let "" be one of the elements in this character vector.
11		#'
12		#' @return \code{NULL} if ... is empty
13		#'
14		#' @keywords internal
15		#'
16		#' @examples
17		#' method.class <- function(a, b, c, ...) {
18		#' check_ellipsis(...)
19		#' }
20		#' method.class <- function(a, b, c, ...) {
21		#' check_ellipsis(..., allowed_args = c("y", "z"))
22		#' }
23		check_ellipsis <- function(..., stop = FALSE, allowed_args = character(0)) {
24	37x	if (!missing(...)) {
25	24x	checkmate::assert_flag(stop)
26	24x	checkmate::assert_character(allowed_args, min.len = 0, null.ok = TRUE, any.missing = FALSE)
27	24x	args <- list(...)
28	24x	arg_names <- names(args)
29	24x	if (is.null(arg_names)) {
30	4x	arg_names <- rep("", length(args))
31		}
32	24x	extra_args <- arg_names[!is.element(arg_names, allowed_args)]
33	24x	if (length(extra_args) == 0) {
34	12x	return(invisible(NULL))
35		}
36	12x	message <- paste(length(extra_args), "total unused argument(s).")
37
38	12x	named_extra_args <- extra_args[!vapply(extra_args, identical, logical(1), "")]
39	12x	if (length(named_extra_args) > 0) {
40	9x	message <- paste0(
41	9x	message,
42		" ",
43	9x	length(named_extra_args),
44	9x	" with name(s): ",
45	9x	paste(named_extra_args, collapse = ", "),
46		"."
47		)
48		}
49	12x	if (stop) {
50	8x	stop(message)
51		} else {
52	4x	warning(message)
53		}
54		}
55		}
56
57		#' Whether the variable name is good to use within Show R Code
58		#'
59		#' Spaces are problematic because the variables must be escaped with backticks.
60		#' Also, they should not start with a number as R may silently make it valid by changing it.
61		#' Therefore, we only allow alphanumeric characters with underscores.
62		#' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters.
63		#'
64		#' @md
65		#'
66		#' @param name `character, single or vector` name to check
67		#' @keywords internal
68		#'
69		#' @examples
70		#' teal.slice:::check_simple_name("aas2df")
71		#' teal.slice:::check_simple_name("ADSL")
72		#' teal.slice:::check_simple_name("ADSLmodified")
73		#' teal.slice:::check_simple_name("ADSL_modified")
74		#' teal.slice:::check_simple_name("ADSL_2")
75		#' teal.slice:::check_simple_name("a1")
76		#' # the following fail
77		#' \dontrun{
78		#' teal.slice:::check_simple_name("1a")
79		#' teal.slice:::check_simple_name("ADSL.modified")
80		#' teal.slice:::check_simple_name("a1...")
81		#' }
82		check_simple_name <- function(name) {
83	448x	checkmate::assert_character(name, min.len = 1, any.missing = FALSE)
84	448x	if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
85	5x	stop(
86	5x	"name '",
87	5x	name,
88	5x	"' must only contain alphanumeric characters (with underscores)",
89	5x	" and the first character must be an alphabetic character"
90		)
91		}
92		}
93
94		#' Resolve the expected bootstrap theme
95		#' @keywords internal
96		get_teal_bs_theme <- function() {
97	2x	bs_theme <- getOption("teal.bs_theme")
98	2x	if (is.null(bs_theme)) {
99	1x	NULL
100	1x	} else if (!inherits(bs_theme, "bs_theme")) {
101	!	warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
102	!	NULL
103		} else {
104	1x	bs_theme
105		}
106		}

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

1		#' Resolve list of filter states
2		#'
3		#' Resolves the state values for `FilterState$set_state()`, which accepts only a list
4		#' with `selected`,`keep_na` and `keep_inf` fields. In case of the `default_filter` function,
5		#' it returns `NULL` as during the initialization of `FilterState` values are set to
6		#' default.
7		#'
8		#' @param x (`list`,`vector`)\cr
9		#' values of the variable used in filter. Depending on the `FilterState` type
10		#' list must contain these fields:
11		#' \itemize{
12		#' \item{`selected`}{ defines initial selection. See notes for more details}
13		#' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values}
14		#' \item{`keep_inf` (`logical`)}{ defines whether to keep or remove `Inf` values}
15		#' }
16		#' If `vector` is provided then `keep_na` and `keep_inf` can be specified
17		#' adding `NA` and `Inf` to the selection vector.
18		#'
19		#' @note
20		#' The value of the `x$selected` needs to be modified according to the type
21		#' of the passed `filter_state`.
22		#'
23		#' @seealso
24		#' - [LogicalFilterState]
25		#' - [ChoicesFilterState]
26		#' - [RangeFilterState]
27		#' - [DateFilterState]
28		#' - [DatetimeFilterState]
29		#'
30		#' @return `list` containing `selected`, `keep_na` and `keep_inf`
31		#'
32		#' @keywords internal
33		#'
34		#' @examples
35		#' teal.slice:::resolve_state(list(c(1, 2), keep_na = FALSE, keep_inf = TRUE))
36		#' teal.slice:::resolve_state(c(1, 2, Inf))
37		#' teal.slice:::resolve_state(list())
38		resolve_state <- function(x) {
39	165x	UseMethod("resolve_state")
40		}
41
42		#' @rdname resolve_state
43		#' @keywords internal
44		#' @export
45		resolve_state.default <- function(x) {
46	86x	state <- list()
47	86x	if (length(x[!(is.infinite(x) \| is.na(x))]) > 0) {
48	86x	state$selected <- x[!(is.infinite(x) \| is.na(x))]
49		}
50
51	86x	if (any(is.na(x))) {
52	1x	state$keep_na <- TRUE
53		}
54
55	86x	if (any(is.infinite(x))) {
56	1x	state$keep_inf <- TRUE
57		}
58
59	86x	state
60		}
61
62		#' @rdname resolve_state
63		#' @keywords internal
64		#' @export
65		resolve_state.default_filter <- function(x, filter_state) { # nolint
66	1x	list()
67		}
68
69		#' @rdname resolve_state
70		#' @keywords internal
71		#' @export
72		resolve_state.list <- function(x) {
73	78x	if (identical(x, list())) {
74	6x	return(x)
75		}
76	72x	if (is.null(names(x))) {
77	10x	names(x) <- rep("", length(x))
78		}
79	72x	x_names <- names(x)
80	72x	if (sum(x_names == "") > 1) {
81	1x	stop("More than one element of filter state is unnamed.")
82	71x	} else if (sum(x_names == "") == 1) {
83	11x	if ("selected" %in% x_names) {
84	1x	stop("Unnamed element of filter state cannot be intepreted as 'selected' because it already exists.")
85		} else {
86	10x	x_idx <- which(x_names == "")
87	10x	names(x)[[x_idx]] <- "selected"
88		}
89		}
90	70x	x
91		}

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

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

1		.onLoad <- function(libname, pkgname) { # nolint
2		# adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R
3	!	teal_default_options <- list(teal.threshold_slider_vs_checkboxgroup = 5)
4	!	op <- options()
5	!	toset <- !(names(teal_default_options) %in% names(op))
6	!	if (any(toset)) options(teal_default_options[toset])
7
8		# Set up the teal logger instance
9	!	teal.logger::register_logger("teal.slice")
10
11	!	invisible()
12		}

1		#' Managing `FilteredData` states
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#' Set, get and remove filter states of `FilteredData` object
5		#'
6		#' @name filter_state_api
7		#'
8		#' @param datasets (`FilteredData`)\cr
9		#' object to store filter state and filtered datasets, shared across modules. For more
10		#' details see [`FilteredData`]
11		#'
12		#' @param filter (`list`)\cr
13		#' You can define filters that show when the app starts. List names should be
14		#' named according to datanames passed to the `data` argument.
15		#' In case of data.frame` the list should be composed as follows:
16		#' ```
17		#' list(<dataname1> = list(<varname1> = ..., <varname2> = ...),
18		#' <dataname2> = list(...),
19		#' ...)
20		#'
21		#' ```
22		#'
23		#' For example, filters for variable `Sepal.Length` in `iris` can be specified as
24		#' follows:
25		#' ```
26		#' list(iris = list(Sepal.Length = list(selected = c(5.0, 7.0))))
27		#' # or
28		#' list(iris = list(Sepal.Length = c(5.0, 7.0)))
29		#' ```
30		#'
31		#' In case developer would like to include `NA` and `Inf` values in the
32		#' filtered dataset.
33		#' ```
34		#' list(Species = list(selected = c(5.0, 7.0), keep_na = TRUE, keep_inf = TRUE))
35		#' list(Species = c(c(5.0, 7.0), NA, Inf))
36		#' ```
37		#'
38		#' To initialize with specific variable filter with all values on start, one
39		#' can use
40		#' ```
41		#' list(Species = list())
42		#' ```
43		#' `filter` should be set with respect to the class of the column:
44		#' * `numeric`: `selected` should be a two elements vector defining the range
45		#' of the filter.
46		#' * `Date`: `selected` should be a two elements vector defining the date-range
47		#' of the filter
48		#' * `POSIXct`: `selected` should be a two elements vector defining the
49		#' `datetime` range of the filter
50		#' * `character` and `factor`: `selected` should be a vector of any length
51		#' defining initial values selected to filter.
52		#' \cr
53		#' `MultiAssayExperiment` `filter` should be specified in slightly different
54		#' way. Since [MultiAssayExperiment::MultiAssayExperiment()] contains
55		#' patient data ([SummarizedExperiment::colData()]) with list of experiments
56		#' ([MultiAssayExperiment::ExperimentList()]), `filter` list should be named
57		#' in the following name.
58		#' \cr
59		#'
60		#' ```
61		#' list(
62		#' <MAE dataname> = list(
63		#' subjects = list(<column in colData> = ..., <column in colData> = ...),
64		#' <experiment name> = list(
65		#' subset = list(<column in rowData of experiment> = ...,
66		#' <column in rowData of experiment> = ...),
67		#' select = list(<column in colData of experiment> = ...,
68		#' <column in colData of experiment> = ...)
69		#' )
70		#' )
71		#' )
72		#' ```
73		#' `filter` is ignored if the app is restored from a bookmarked state.
74		#'
75		#' @return
76		#' - set, remove and clear returns `NULL`
77		#' - get returns named `list` of the same structure as described in `filter` argument.
78		#'
79		#' @examples
80		#' utils::data(miniACC, package = "MultiAssayExperiment")
81		#'
82		#' datasets <- init_filtered_data(
83		#' x = list(
84		#' iris = list(dataset = iris),
85		#' mae = list(dataset = miniACC)
86		#' )
87		#' )
88		#' fs <- list(
89		#' iris = list(
90		#' Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE),
91		#' Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE)
92		#' ),
93		#' mae = list(
94		#' subjects = list(
95		#' years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE),
96		#' vital_status = list(selected = "1", keep_na = FALSE),
97		#' gender = list(selected = "female", keep_na = TRUE)
98		#' ),
99		#' RPPAArray = list(
100		#' subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE))
101		#' )
102		#' )
103		#' )
104		#'
105		#' # set initial filter state
106		#' isolate(set_filter_state(datasets, filter = fs))
107		#'
108		#' # get filter state
109		#' get_filter_state(datasets)
110		#'
111		#' # modify filter state
112		#' isolate(
113		#' set_filter_state(
114		#' datasets,
115		#' filter = list(iris = list(Species = list(selected = "setosa", keep_na = TRUE)))
116		#' )
117		#' )
118		#'
119		#' # remove specific filters
120		#' isolate(
121		#' remove_filter_state(datasets,
122		#' filter = list(
123		#' iris = "Species",
124		#' mae = list(
125		#' subjects = c("years_to_birth", "vital_status")
126		#' )
127		#' )
128		#' )
129		#' )
130		#' # remove all states
131		#' clear_filter_states(datasets)
132		NULL
133
134		#' @rdname filter_state_api
135		#' @export
136		set_filter_state <- function(datasets, filter) {
137	!	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
138	!	checkmate::assert_list(filter, min.len = 0, null.ok = TRUE)
139	!	if (length(filter) > 0) {
140	!	datasets$set_filter_state(filter)
141		}
142	!	invisible(NULL)
143		}
144
145		#' @rdname filter_state_api
146		#' @export
147		get_filter_state <- function(datasets) {
148	!	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
149	!	if (shiny::isRunning()) {
150	!	datasets$get_filter_state()
151		} else {
152	!	isolate(datasets$get_filter_state())
153		}
154		}
155
156		#' @rdname filter_state_api
157		#' @export
158		remove_filter_state <- function(datasets, filter) {
159	!	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
160	!	checkmate::assert_list(filter, min.len = 0, null.ok = TRUE)
161	!	if (length(filter) > 0) {
162	!	datasets$remove_filter_state(filter)
163		}
164	!	invisible(NULL)
165		}
166
167		#' @rdname filter_state_api
168		#' @export
169		clear_filter_states <- function(datasets) {
170	!	checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
171	!	datasets$remove_all_filter_states()
172	!	invisible(NULL)
173		}