teal.picks coverage - 93.60%

Files
Source

#' Resolve `picks`
#'
#' Resolve iterates through each `picks` element and determines values .
#' @param x ([picks()]) settings for picks.
#' @param data ([teal_data()] `environment` or `list`) any data collection supporting object extraction with `[[`.
#' Used to determine values of unresolved `picks`.
#'
#' @returns resolved `picks`.
#' @export
#'
#' @examples
#' x <- picks(datasets(tidyselect::where(is.data.frame)), variables("a", "a"))
#' data <- list(
#'   df1 = data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]),
#'   df2 = data.frame(a = LETTERS[1:5], b = 1:5),
#'   m = matrix()
#' )
#' resolver(x = x, data = data)
resolver <- function(x, data) {
  checkmate::assert_class(x, "picks")
  checkmate::assert(
    is.environment(data),
    checkmate::check_list(data, names = "unique")
  )
  data_i <- data
  for (i in seq_along(x)) {
    determined_i <- determine(x[[i]], data = data_i)
    data_i <- determined_i$data
    x[[i]] <- determined_i$x
  }
  x
}

#' A method that should take a type and resolve it.
#'
#' Generic that makes the minimal check on spec.
#' Responsible of subsetting/extract the data received and check that the type matches
#' @param x The specification to resolve.
#' @param data The minimal data required.
#' @return A list with two elements, the `type` resolved and the data extracted.
#' @keywords internal
determine <- function(x, data) {
  if (is.null(data)) { # this happens when <previous>$selected=NULL
    return(list(x = .nullify_pick(x)))
  }
  UseMethod("determine")
}

#' @export
determine.datasets <- function(x, data) {
  checkmate::assert(is.environment(data), is.list(data))
  data <- as.list(data)
  x$choices <- .determine_choices(x = x$choices, data = data)
  x$selected <- .determine_selected(
    x = x$selected,
    data = data[intersect(x$choices, names(data))],
    multiple = attr(x, "multiple")
  )
  list(x = x, data = .extract(x, data))
}

#' @export
determine.variables <- function(x, data) {
  checkmate::assert_multi_class(data, c("data.frame", "tbl_df", "data.table", "DataFrame"))
  if (ncol(data) <= 0L) {
    warning("Selected dataset has no columns", call. = FALSE)
    return(list(x = .nullify_pick(x)))
  }

  old <- select_env$operators
  select_env$active <- TRUE
  on.exit(select_env$operators <- old, add = TRUE)
  on.exit(select_env$active <- FALSE, add = TRUE)

  x$choices <- .determine_choices(x$choices, data = data)
  # change data to add columns that combine interaction vars
  custom_operators <- unique(select_env$operators) %||% x$operators

  for (ix in seq_along(custom_operators)) {
    new_choice <- rlang::set_names(attr(custom_operators[[ix]], "var_name", TRUE))
    data <- .operator_mutate(custom_operators[[ix]], new_choice, data)
    x$choices <- c(x$choices, new_choice)
    x$operators <- custom_operators
  }

  x$selected <- .determine_selected(
    x$selected,
    data = data[intersect(x$choices, colnames(data))],
    multiple = attr(x, "multiple")
  )
  list(x = x, data = .extract(x, data))
}

#' @export
determine.values <- function(x, data) {
  data <- if (ncol(data) > 1) {
    apply(data, 1, toString)
  } else {
    data[[1]]
  }

  data <- stats::setNames(unique(data), unique(data))
  is_ranged <- if (.is_ranged(x$choices) || .is_ranged(x$selected)) {
    TRUE
  } else {
    FALSE
  }

  if (is_ranged && !is.numeric(data) && !inherits(data, c("Date", "POSIXct"))) {
    warning(
      "Column used with `ranged()` must be numeric, Date, or POSIXct, but got: ",
      paste(class(data), collapse = "/"),
      ". Please adjust `variables(choices)` to only select supported column types.",
      call. = FALSE
    )
    x$choices <- NULL
    x$selected <- NULL
    return(list(x = x))
  }

  x$choices <- .determine_choices(x$choices, data = data) # .determine_* uses names
  x$selected <- if (length(x$choices)) {
    .determine_selected(x$selected, data = stats::setNames(x$choices, x$choices), multiple = attr(x, "multiple"))
  }

  # Only return max and minimal value
  if (is_ranged) {
    if (!is.null(x$choices)) {
      x$choices <- .as_ranged(x$choices)
    }
    if (!is.null(x$selected)) {
      x$selected <- .as_ranged(range(x$selected, na.rm = TRUE))
    }
  }

  list(x = x) # no picks element possible after picks(..., values) (no need to pass data further)
}


#' Evaluate delayed choices
#'
#' @param data (`list`, `data.frame`, `vector`)
#' @param x (`character`, `quosure`, `function(x)`) to determine `data` elements to extract.
#' @param multiple (`logical(1)`) whether multiple selection is possible.
#'
#' @details
#'
#' ## Various ways to evaluate choices/selected.
#'
#' Function resolves `x` to determine `choices` or `selected`. `x` is matched in multiple ways with
#' `data` to return valid choices:
#' - `x (character)`: values are matched with names of data and only intersection is returned.
#' - `x (tidyselect-helper)`: using [tidyselect::eval_select]
#' - `x (function)`: function is executed on each element of `data` to determine where function returns TRUE
#'
#' Mechanism is robust in a sense that it never fails (`tryCatch`) and returns `NULL` if no-match found. `NULL`
#' in [determine()] is handled gracefully, by setting `NULL` to all following components of `picks`.
#'
#' In the examples below you can replace `.determine_delayed` with `.determine_choices` or `.determine_selected`.
#'
#' - `character`: refers to the object name in `data`, for example
#'    ```
#'    .determine_delayed(data = iris, x = "Species")
#'    .determine_delayed(data = iris, x = c("Species", "inexisting"))
#'    .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars)), x = "iris")
#'    ```
#' - `quosure`: delayed (quoted) `tidyselect-helper` to be evaluated through `tidyselect::eval_select`. For example
#'   ```
#'   .determine_delayed(data = iris, x = rlang::quo(tidyselect::starts_with("Sepal")))
#'   .determine_delayed(data = iris, x = rlang::quo(1:2))
#'   .determine_delayed(data = iris, x = rlang::quo(Petal.Length:Sepal.Length))
#'   ```
#' - `function(x)`: predicate function returning a logical flag. Evaluated for each `data` element. For example
#'   ```
#'
#'   .determine_delayed(data = iris, x = is.numeric)
#'   .determine_delayed(data = letters, x = function(x) x > "c")
#'   .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars, a = "a")), x = is.data.frame)
#'   ```
#'
#' @return `character` containing names/levels of `data` elements which match `x`, with two differences:
#' - `.determine_choices` returns vector named after data labels
#' - `.determine_selected` cuts vector to scalar when `multiple = FALSE`
#'
#' @keywords internal
.determine_choices <- function(x, data) {
  out <- .determine_delayed(data = data, x = x)
  if (!is.null(names(data)) && !is.atomic(data) && is.character(out) && is.null(names(out))) {
    # only named non-atomic can have label
    # don't rename if names provided by app dev
    labels <- vapply(
      out,
      FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1],
      FUN.VALUE = character(1)
    )
    stats::setNames(out, labels)
  } else {
    out
  }
}

#' @rdname dot-determine_choices
.determine_selected <- function(x, data, multiple = FALSE) {
  if (!is.null(x) && length(data)) {
    out <- .determine_delayed(data = data, x = x)
    if (!isTRUE(multiple) && length(out) > 1) {
      warning(
        "`multiple` has been set to `FALSE`, while selected contains multiple values, forcing to select first:",
        rlang::as_label(x)
      )
      out <- out[1]
    }
    out
  }
}

#' @rdname dot-determine_choices
.determine_delayed <- function(x, data) {
  if (length(dim(data)) == 2L) { # for example matrix
    data <- as.data.frame(data)
  }
  out <- tryCatch( # app developer might provide failing function
    if (is.atomic(x) && length(x)) {
      # don't need to evaluated eager choices - just make sure choices are subset of possible
      x[which(x %in% .possible_choices(data))]
    } else if (is.function(x)) {
      if (inherits(x, "des-delayed")) {
        x(data)
      } else {
        idx_match <- unique(which(vapply(data, x, logical(1))))
        .possible_choices(data[idx_match])
      }
    } else if (rlang::is_quosure(x)) {
      # app developer might provide failing function
      idx_match <- unique(tidyselect::eval_select(expr = x, data))
      .possible_choices(data[idx_match])
    },
    error = function(e) NULL # not returning error to avoid design complication to handle errors
  )

  out <- out[!is.infinite(out)]
  out <- out[!is.na(out)]

  if (length(out) == 0) {
    warning(
      "None of the `choices/selected`: ", rlang::as_label(x), "\n",
      "are subset of: ", toString(.possible_choices(data), width = 30), "\n",
      "Emptying choices..."
    )
    return(NULL)
  }
  # unique() for idx containing duplicated values
  if (is.atomic(out) && length(out)) out # this function should return atomic vector of length > 1 or NULL
}

#' @rdname dot-determine_choices
.possible_choices <- function(data) {
  if (is.factor(data)) {
    levels(data)
  } else if (is.atomic(data)) {
    unique(data)
  } else {
    names(data)
  }
}

.extract <- function(x, data) {
  if (length(x$selected) == 0) {
    NULL # this nullifies following pick-elements. See determine (generic)
  } else if (length(x$selected) == 1 && inherits(x, "datasets")) {
    data[[x$selected]]
  } else if (all(x$selected %in% names(data))) {
    data[x$selected]
  }
}

.nullify_pick <- function(x) {
  x$choices <- NULL
  x$selected <- NULL
  x
}

.range_without_warnings <- function(..., pattern = "no non-missing arguments to (min|max)") {
  withCallingHandlers(
    range(...),
    warning = function(w) {
      if (grepl(pattern, conditionMessage(w))) invokeRestart("muffleWarning")
    }
  )
}

#' `tidyselect` helpers
#'
#' @description
#' #' `r lifecycle::badge("experimental")`
#' Predicate functions simplifying `picks` specification.
#' @examples
#' # select factor column but exclude foreign keys
#' variables(choices = is_categorical(min.len = 2, max.len = 10))
#'
#' @name tidyselectors
#' @rdname tidyselectors
#' @param min.len (`integer(1)`) minimal number of unique values
#' @param max.len (`integer(1)`) maximal number of unique values
#' @return A `tidyselector` that can be used directly in `choices` or `selected` of `variables()` in `picks()`.
#' @export
#' @examples
#' # Supports tidyselect helpers, e.g. to select all categorical variables with 2 to 10 unique values
#' dplyr::select(iris, dplyr::where(is_categorical(2, 10)))
#'
#' p <- picks(
#'   datasets(is.data.frame, 2L),
#'   variables(is_categorical(2, 10))
#' )
#' resolver(data = list(mtcars = mtcars, iris = iris), x = p)
is_categorical <- function(min.len, max.len) {
  # todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len
  #       without a need to compute unique on the whole vector.
  if (missing(max.len) && missing(min.len)) {
    function(x) is.factor(x) || is.character(x)
  } else if (!missing(max.len) && missing(min.len)) {
    checkmate::assert_int(max.len, lower = 0)
    function(x) (is.factor(x) || is.character(x)) && length(unique(x)) <= max.len
  } else if (!missing(min.len) && missing(max.len)) {
    checkmate::assert_int(min.len, lower = 0)
    function(x) (is.factor(x) || is.character(x)) && length(unique(x)) >= min.len
  } else {
    checkmate::assert_int(min.len, lower = 0)
    checkmate::assert_int(max.len, lower = 0)
    checkmate::assert_true(max.len >= min.len)
    function(x) {
      (is.factor(x) || is.character(x)) && {
        n <- length(unique(x))
        n >= min.len && n <= max.len
      }
    }
  }
}


#' Select a range
#'
#' Helper to work with ranges. Setting `choices` or `selected` to range using
#' `ranged()` in any of them will automatically create a `numeric`, `Date` or `POSIXct`
#' input to filter. `variables(choices)` must only refer to `numeric`, `Date`, or `POSIXct`
#' columns. An informative error is raised if the resolved column type is unsupported.
#' @param min (`numeric(1)`) Minimal value.
#' @param max (`numeric(1)`) Maximal value.
#' @return A function that allows the use of a range in `choices` or `selected` of `values()` in
#' `numeric`, `Date`, or `POSIXct` variables.
#' @export
#' @examples
#' p <- picks(
#'   datasets(choices = "mtcars"),
#'   variables(choices = is.numeric, selected = 1),
#'   values(choices = ranged(), ranged(20, 30))
#' )
#' resolver(data = list("mtcars label" = mtcars), x = p)
ranged <- function(min = -Inf, max = Inf) {
  checkmate::assert_number(min)
  checkmate::assert_number(max)
  if (min > max) {
    stop("`min` must be lower than `max`")
  }
  .as_ranged(
    function(x) {
      !is.na(x) & x <= max & x >= min
    }
  )
}

#' Check if choices/selected is a range.
#'
#' @noRd
.is_ranged <- function(x) {
  inherits(x, "ranged")
}

#' Set "ranged" class to the object. Be watchful as
#' it is used in two contexts.
#' 1. Unresolved range in `values`'s `choices` and `selected` - setting a range predicate to
#' be resolved in `determine`
#' 2. Resolved range - sets a class to the `choices` and `selected` to inform that resolved vector
#' is a range, to show a `numericRangeInput` and to filter values by `lower >= x <= upper`
#'
#' @noRd
.as_ranged <- function(x) {
  class(x) <- c(class(x), "ranged")
  x
}

#' Checks `varname` argument and convert to call
#'
#' Checks `varname` type and parse if it's a `character`.
#'
#' @param varname (`name` or `call` or `character(1)`)
#' name of the variable
#'
#' @returns the parsed `varname`.
#'
#' @keywords internal
#'
call_check_parse_varname <- function(varname) {
  checkmate::assert(
    checkmate::check_string(varname),
    checkmate::check_class(varname, "call"),
    checkmate::check_class(varname, "name")
  )
  if (is.character(varname)) {
    parsed <- parse(text = varname, keep.source = FALSE)
    if (length(parsed) == 1) {
      varname <- as.name(varname)
    } else {
      stop(
        sprintf(
          "Problem with parsing '%s'. Not able to process multiple calls",
          varname
        )
      )
    }
  }
  varname
}

#' Choices condition call
#'
#' Compose choices condition call from inputs.
#'
#' @details
#' `choices` can be vector of any type but for some output might be converted:
#' * `factor` call is composed on choices converted to `character`;
#' * `Date` call is composed on choices converted to `character` using
#' `format(choices)`;
#' * `POSIXct`, `POSIXlt` call is composed on choices converted to `character` using
#' `format(choices)`.
#'
#' One has to be careful here as formatted date-time variable might loose
#' some precision (see `format` argument in [format.POSIXlt()] and output call
#' could be insufficient for exact comparison. In this case one should specify
#' `varname = trunc(<varname>)` and possibly convert `choices` to `character`).
#'
#' @param varname (`name` or `call` or `character(1)`)
#' name of the variable.
#' @param choices (`vector`)
#' `varname` values to match using the `==` (single value) or `%in%` (vector)
#' condition.
#'
#' @return `call`.
#'
#' @keywords internal
#'
call_condition_choice <- function(varname, choices) {
  varname <- call_check_parse_varname(varname)

  if (is.factor(choices)) {
    choices <- as.character(choices)
  } else if (inherits(choices, "Date")) {
    choices <- format(choices)
  } else if (inherits(choices, c("POSIXct", "POSIXlt"))) {
    choices <- format(choices)
  }


  if (length(choices) == 1) {
    call("==", varname, unname(choices))
  } else {
    c_call <- do.call(
      "call",
      append(list("c"), unname(choices))
    )
    # c_call needed because it needs to be vector call
    # instead of vector. SummarizedExperiment.subset
    # handles only vector calls
    call("%in%", as.name(varname), c_call)
  }
}

#' `numeric` range condition call
#'
#' Compose `numeric` range condition call from inputs.
#'
#' @param varname (`name` or `character(1)`)
#' name of the variable.
#'
#' @param range (`numeric(2)`)
#' range of the variable.
#'
#' @return `call`.
#'
#' @keywords internal
#'
call_condition_range <- function(varname, range) {
  checkmate::assert_numeric(range, len = 2, sorted = TRUE)

  varname <- call_check_parse_varname(varname)
  call(
    "&",
    call(">=", varname, unname(range[1])),
    call("<=", varname, unname(range[2]))
  )
}

#' `logical` variable condition call
#'
#' Compose `logical` variable condition call from inputs.
#'
#' @param varname (`name` or `character(1)`)
#' name of the variable
#'
#' @param choice (`logical(1)`)
#' chosen value
#'
#' @return `call`.
#'
#' @keywords internal
#'
call_condition_logical <- function(varname, choice) {
  checkmate::assert_flag(choice)
  varname <- call_check_parse_varname(varname)

  if (choice) {
    varname
  } else if (!choice) {
    call("!", varname)
  } else {
    stop(
      "Unknown filter state", toString(choice),
      " for logical var ", as.character(varname)
    )
  }
}

#' `POSIXct` range condition call
#'
#' Compose `POSIXct` range condition call from inputs.
#'
#' @param varname (`name` or `character(1)`) name of the variable.
#' @param range (`POSIXct`) range of the variable.
#' Be aware that output uses truncated range format `"%Y-%m-%d %H:%M:%S"`,
#' which means that some precision might be lost.
#' @param timezone (`character(1)`) specifies the time zone to be used for the conversion.
#' By default `Sys.timezone()` is used.
#'
#' @return `call`.
#'
#' @keywords internal
#'
call_condition_range_posixct <- function(varname, range, timezone = Sys.timezone()) {
  checkmate::assert_posixct(range, len = 2, sorted = TRUE)
  checkmate::assert_string(timezone)
  varname <- call_check_parse_varname(varname)

  range[1] <- trunc(range[1], units = c("secs"))
  range[2] <- trunc(range[2] + 1, units = c("secs"))

  range <- format.POSIXct(
    unname(range),
    format = "%Y-%m-%d %H:%M:%S",
    tz = timezone
  )

  call(
    "&",
    call(">=", varname, call("as.POSIXct", range[1], tz = timezone)),
    call("<", varname, call("as.POSIXct", range[2], tz = timezone))
  )
}

#' `Date` range condition call
#'
#' Compose `Date` range condition call from inputs.
#'
#' @param varname (`name` or `character(1)`) name of the variable.
#' @param range (`Date`) range of the variable.
#'
#' @return `call`.
#'
#' @keywords internal
#'
call_condition_range_date <- function(varname, range) {
  checkmate::assert_date(range, len = 2)
  checkmate::assert_true(range[2] >= range[1])
  varname <- call_check_parse_varname(varname)

  call(
    "&",
    call(">=", varname, call("as.Date", as.character(range[1]))),
    call("<=", varname, call("as.Date", as.character(range[2])))
  )
}

#' Combine calls by operator
#'
#' Combine list of calls by specific operator.
#'
#' @param operator (`character(1)` or `name`) name / symbol of the operator.
#' @param calls (`list` of calls) list containing calls to be combined by `operator`.
#'
#' @return A combined `call`.
#'
#' @keywords internal
#'
calls_combine_by <- function(operator, calls) {
  checkmate::assert_string(operator)
  stopifnot(
    all(
      vapply(
        X = calls,
        FUN.VALUE = logical(1),
        FUN = function(x) is.language(x) || is.logical(x)
      )
    )
  )
  Reduce(
    x = calls,
    f = function(x, y) call(operator, x, y)
  )
}

#' `dplyr::select` call
#'
#' Create `dplyr::select` call from `dataname` and `variables`
#' @param dataname (`character(1)`) name of the dataset
#' @param variables (`list` of `character`) variables to select. If list is named then
#'  variables will be renamed if their name is different than its value
#'  (this produces a call `select(..., <name> = <value>)`).
#' @return `call`.
#' @keywords internal
.call_dplyr_select <- function(dataname, variables) {
  as.call(
    c(
      list(
        str2lang("dplyr::select"),
        str2lang(dataname)
      ),
      lapply(unname(variables), as.name)
    )
  )
}

#' `dplyr::filter` call
#'
#' Create a `dplyr::filter` call
#' @param x (`list`) containing `variables` and `values`
#' @return `call`.
#' @keywords internal
.call_dplyr_filter <- function(x) {
  if (any(!names(x) %in% c("variables", "values"))) {
    predicates <- lapply(unname(x), .predicates)
    predicates <- Filter(length, predicates)
  } else {
    predicates <- .predicates(x)
  }

  as.call(c(list(str2lang("dplyr::filter")), predicates))
}

.predicates <- function(x) {
  if (is.numeric(x$values) && .is_ranged(x$values)) {
    call_condition_range(varname = x$variables, range = x$values)
  } else if (inherits(x$values, "Date") && .is_ranged(x$values)) {
    call_condition_range_date(varname = x$variables, range = x$values)
  } else if (inherits(x$values, "POSIXct") && .is_ranged(x$values)) {
    call_condition_range_posixct(varname = x$variables, range = x$values)
  } else if (is.logical(x$values)) {
    call_condition_logical(varname = x$variables, choice = x$values)
  } else if (
    checkmate::test_list(x$operators, types = "operator", min.len = 1) &&
      .is_operator_selected(x$operators, x$variables)
  ) {
    if (length(x$operators) > 1) {
      showNotification("Only a single complex operator can be used at a time when filtering by values.", type = "error")
      return(NULL)
    }
    if (length(x$variables) > 1) {
      showNotification(
        "A complex operator filter cannot be combined with other variables. Filtering by the first variable only.",
        type = "error"
      )
      return(NULL)
    }
    .call_condition_operators(x$operators[[1]], choices = x$values)
  } else if (length(x$variables)) {
    if (is.factor(x$values)) {
      x$values <- as.numeric(levels(x$values))[x$values]
    }

    variable <- if (length(x$variables) > 1) {
      as.call(
        list(
          quote(apply),
          as.call(
            c(
              list(quote(data.frame)),
              unname(lapply(x$variables, as.name))
            )
          ),
          1,
          quote(toString)
        )
      )
    } else {
      x$variables
    }
    call_condition_choice(varname = variable, choices = x$values)
  }
}

.call_mutate_operators <- function(variables, operators_ix, dataname, operators) {
  operators <- rlang::set_names(operators, vapply(operators, attr, which = "var_name", FUN.VALUE = character(1)))
  select_new <- variables[operators_ix]
  select_tmp <- unname(unlist(operators[select_new]))
  select_call <- .call_dplyr_select(
    dataname = dataname,
    variables = unique(c(variables[!operators_ix], select_tmp))
  )

  select_call
}

#' Interactive picks
#'
#' @description
#'
#' Creates UI and server components for interactive [picks()] in Shiny modules. The module is based on
#' configuration provided via [picks()] and its responsibility is to determine relevant input
#' values
#'
#'
#' The module supports both single and combined `picks`:
#' - Single `picks` objects for a single input
#' - Named lists of `picks` objects for multiple inputs
#'
#' @param id (`character(1)`) Shiny module ID
#' @param picks (`picks` or `list`) object created by `picks()` or a named list of such objects
#' @param container (`character(1)` or `function`) UI container type. Can be one of `htmltools::tags`
#' functions. By default, elements are wrapped in a package-specific drop-down.
#' @param data (`reactive`) Reactive expression returning the data object to be used for populating choices
#'
#' @return
#' - `picks_ui()`: UI elements for the input controls
#' - `picks_srv()`: Server-side reactive logic returning the processed data
#'
#' @details
#' The module uses S3 method dispatch to handle different ways to provide `picks`:
#' - `.picks` methods handle single `picks`` object
#' - `.list` methods handle multiple `picks` objects
#'
#' The UI component (`picks_ui`) creates the visual elements, while the
#' server component (`picks_srv`) manages the reactive logic,
#'
#' @seealso [picks()] for creating `picks`` objects
#'
#' @name picks_module
#' @examples
#' library(shiny)
#'
#' example_pick <- picks(
#'   datasets("ADSL"),
#'   variables(selected = c("SEX", "COUNTRY", "ARMCD"))
#' )
#' ui <- fluidPage(
#'   picks_ui("my_picks", picks = example_pick),
#'   h4("Resolved picks:"),
#'   verbatimTextOutput("result"),
#'   h4("Table:"),
#'   tableOutput("table")
#' )
#' server <- function(input, output, session) {
#'   data <- teal.data::teal_data("ADSL" = teal.data::rADSL)
#'   teal.data::join_keys(data) <- teal.data::default_cdisc_join_keys["ADSL"]
#'   selectors <- picks_srv(
#'     picks = list(my_picks = example_pick),
#'     data = reactive(data)
#'   )
#'   anl <- merge_srv("merge", data = reactive(data), selectors = selectors)
#'   output$result <- renderPrint(cat(gsub("\033\\[[0-9;]*m", "", format(selectors$my_picks()))))
#'   output$table <- renderTable(anl$data()$anl)
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
NULL

#' @rdname picks_module
#' @export
picks_ui <- function(id, picks, container = "badge_dropdown") {
  checkmate::assert_string(id)
  UseMethod("picks_ui", picks)
}

#' @rdname picks_module
#' @export
picks_ui.list <- function(id, picks, container) {
  checkmate::assert_list(picks, names = "unique")
  ns <- shiny::NS(id)
  sapply(
    Filter(length, names(picks)),
    USE.NAMES = TRUE,
    function(name) picks_ui(ns(name), picks[[name]], container = container)
  )
}

#' @rdname picks_module
#' @export
picks_ui.picks <- function(id, picks, container) {
  ns <- shiny::NS(id)
  badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span)
  content <- lapply(picks, function(x) .pick_ui(id = ns(methods::is(x))))
  if (missing(container)) {
    htmltools::tags$div(
      if (all(vapply(picks, is_pick_fixed, logical(1)))) {
        badge_fixed(id = ns("inputs"), badge_label, htmltools::tagList(content))
      } else {
        badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content))
      }
    )
  } else {
    if (!any(sapply(htmltools::tags, identical, container))) {
      stop("Container should be one of `htmltools::tags`")
    }
    htmltools::tags$div(container(content))
  }
}

#' @rdname picks_module
#' @export
picks_srv <- function(id = "", picks, data) {
  checkmate::assert_string(id)
  checkmate::assert_class(data, "reactive")
  UseMethod("picks_srv", picks)
}

#' @rdname picks_module
#' @export
picks_srv.list <- function(id, picks, data) {
  checkmate::assert_named(picks, type = "unique")
  sapply(
    names(Filter(length, picks)),
    USE.NAMES = TRUE,
    function(name) picks_srv(name, picks[[name]], data)
  )
}

#' @rdname picks_module
#' @export
picks_srv.picks <- function(id, picks, data) {
  shiny::moduleServer(id, function(input, output, session) {
    picks_resolved <- shiny::reactiveVal(
      restoreValue(
        session$ns("picks"),
        resolver(picks, shiny::isolate(data()))
      )
    )

    session$onBookmark(function(state) {
      logger::log_debug("picks_srv@onBookmark: storing current picks")
      state$values$picks <- picks_resolved()
    })

    exportTestValues(
      open_id_fmt = session$ns("%s-selected_open"),
      selected_id_fmt = session$ns("%s-selected"),
      range_id_fmt = session$ns("%s-range"),
      picks_resolved = picks_resolved()
    )

    badge <- shiny::reactive({
      lapply(
        picks_resolved(),
        function(x) {
          label <- if (inherits(x, "values")) {
            if (!setequal(x$choices, x$selected)) {
              bsicons::bs_icon("funnel")
            }
          } else if (length(x$selected)) {
            toString(x$selected)
          } else {
            "~"
          }
          label
        }
      )
    })

    output$summary <- shiny::renderUI({
      badge_value <- badge()
      hover_text <- paste(
        vapply(
          names(badge_value)[names(badge_value) %in% c("datasets", "variables")],
          function(x) sprintf("%s: %s", x, paste(badge_value[[x]], collapse = ", ")),
          FUN.VALUE = character(1)
        ),
        collapse = "\n"
      )
      htmltools::tags$span(title = hover_text, tagList(badge_value))
    })

    Reduce(
      function(this_data, slot_name) { # this_data is a (drilled-down) data for current pick
        choices <- reactiveVal(isolate(picks_resolved())[[slot_name]]$choices)
        selected <- reactiveVal(isolate(picks_resolved())[[slot_name]]$selected)
        all_choices <- shiny::reactive(determine(x = picks[[slot_name]], data = this_data())$x$choices)

        observeEvent(all_choices(), ignoreInit = TRUE, {
          current_selected <- picks_resolved()[[slot_name]]$selected
          new_selected <- if (is.numeric(current_selected) && is.numeric(all_choices())) {
            c(
              max(current_selected[1], all_choices()[1], na.rm = TRUE),
              min(current_selected[2], all_choices()[2], na.rm = TRUE)
            )
          } else {
            intersect(current_selected, all_choices())
          }

          .update_rv(
            selected, new_selected,
            sprintf("picks_srv@1 %s$%s$selected is outside of the possible choices", id, slot_name)
          )
          .update_rv(
            choices, all_choices(),
            sprintf("picks_srv@1 %s$%s$choices is outside of the possible choices", id, slot_name)
          )
        })

        observeEvent(picks_resolved()[[slot_name]], ignoreInit = TRUE, ignoreNULL = FALSE, {
          .update_rv(choices, picks_resolved()[[slot_name]]$choices, log = "picks_srv@1 update input choices")
          .update_rv(selected, picks_resolved()[[slot_name]]$selected, log = "picks_srv@1 update input selected")
        })

        args <- attributes(picks[[slot_name]])
        args <- args[!names(args) %in% c("names", "class")]

        .pick_srv(
          id = slot_name,
          pick_type = slot_name,
          choices = choices,
          selected = selected,
          args = args[!names(args) %in% c("names", "class")],
          data = this_data
        )

        # this works as follows:
        #  Each observer is observes input$selected of i-th element of picks ($datasets, $variables, ...)
        shiny::observeEvent(
          selected(),
          ignoreInit = TRUE, # because picks_resolved is already resolved and `selected()` is being set
          ignoreNULL = FALSE, # because input$selected can be empty
          {
            .resolve(
              selected(),
              slot_name = slot_name,
              picks_resolved = picks_resolved,
              old_picks = picks,
              data = data() # data() object needed as we resolve the WHOLE picks INSTEAD OF one picks element.
            )
          }
        )

        shiny::reactive(.extract(x = picks_resolved()[[slot_name]], this_data()))
      },
      x = names(picks),
      init = data
    )

    picks_resolved
  })
}

.pick_ui <- function(id) {
  ns <- shiny::NS(id)
  uiOutput(ns("selected_container"))
}

.pick_srv <- function(id, pick_type, choices, selected, data, args) {
  checkmate::assert_string(id)
  checkmate::assert_class(choices, "reactiveVal")
  checkmate::assert_class(selected, "reactiveVal")
  checkmate::assert_list(args)

  shiny::moduleServer(id, function(input, output, session) {
    choices_opt_content <- shiny::reactive({
      if (pick_type != "values") {
        sapply(
          choices(),
          function(choice) {
            icon <- toString(icon(.picker_icon(data()[[choice]]), lib = "font-awesome"))
            label <- attr(data()[[choice]], "label")
            paste(
              icon,
              choice,
              if (!is.null(label) && !is.na(label) && !identical(label, choice)) {
                toString(tags$small(label, class = "text-muted"))
              }
            )
          }
        )
      }
    })

    output$selected_container <- renderUI({
      logger::log_debug(".pick_srv@1 rerender {pick_type} input")
      .validate_is_eager(choices())
      .validate_is_eager(selected())
      if (!length(choices()) || isTRUE(args$fixed)) {
        .pick_ui_fixed(session$ns("selected"), selected())
      } else if (.is_ranged(choices()) && inherits(choices(), "Date")) {
        .pick_ui_date(
          session$ns("range"),
          label = sprintf("Select %s range:", pick_type),
          choices = choices(),
          selected = selected(),
          args = args
        )
      } else if (.is_ranged(choices()) && inherits(choices(), "POSIXct")) {
        .pick_ui_posixct(
          session$ns("range"),
          label = sprintf("Select %s range:", pick_type),
          choices = choices(),
          selected = selected(),
          args = args
        )
      } else if (.is_ranged(choices())) {
        .pick_ui_numeric(
          session$ns("range"),
          label = sprintf("Select %s range:", pick_type),
          choices = choices(),
          selected = selected(),
          args = args
        )
      } else {
        .pick_ui_categorical(
          session$ns("selected"),
          label = sprintf("Select %s:", pick_type),
          choices = choices(),
          selected = selected(),
          multiple = args$multiple,
          choicesOpt = list(content = isolate(choices_opt_content())),
          args = args[!names(args) %in% c("multiple")]
        )
      }
    }) |> bindEvent(choices(), ignoreNULL = FALSE) # never change on selected()

    # for numeric / date / posixct range
    range_debounced <- shiny::reactive(input$range) |> debounce(1000)
    shiny::observeEvent(range_debounced(), {
      new_value <- input$range
      if (inherits(choices(), "POSIXct")) {
        new_value <- as.POSIXct(new_value)
      }
      .update_rv(
        selected,
        .as_ranged(new_value),
        log = ".pick_srv@2 update selected after input changed"
      )
    })


    # for non-numeric
    shiny::observeEvent(input$selected_open, {
      # Update when closes and the input is different from what it was selected
      if (!isTRUE(input$selected_open) && !isTRUE(all.equal(input$selected, sort(selected())))) {
        # ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""])
        new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected)
        if (args$ordered) {
          new_selected <- c(intersect(selected(), new_selected), setdiff(new_selected, selected()))
        }
        .update_rv(selected, new_selected, log = ".pick_srv@1 update selected after input changed")
      }
    })
    selected
  })
}

.pick_ui_fixed <- function(id, selected) {
  htmltools::tags$div(
    class = "form-group shiny-input-container",
    style = "visibility: hidden; position: absolute;",
    htmltools::tags$input(
      id = id,
      disabled = "disabled",
      value = selected
    )
  )
}

.pick_ui_date <- function(id, label, choices, selected, args) {
  shiny::dateRangeInput(
    inputId = id,
    label = label,
    min = choices[1],
    max = utils::tail(choices, 1),
    start = selected[1],
    end = utils::tail(selected, 1)
  )
}

.pick_ui_posixct <- function(id, label, choices, selected, args) {
  shiny::dateRangeInput(
    inputId = id,
    label = label,
    min = as.Date(choices[1]),
    max = as.Date(utils::tail(choices, 1)),
    start = as.Date(selected[1]),
    end = as.Date(utils::tail(selected, 1))
  )
}

.pick_ui_numeric <- function(id, label, choices, selected, args) {
  shinyWidgets::numericRangeInput(
    inputId = id,
    label = label,
    min = unname(choices[1]),
    max = unname(utils::tail(choices, 1)),
    value = unname(selected)
  )
}

.pick_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { # nolint
  htmltools::div(
    style = "max-width: 500px;",
    shinyWidgets::pickerInput(
      inputId = id,
      label = label,
      choices = choices,
      selected = selected,
      multiple = multiple,
      choicesOpt = choicesOpt,
      options = c(
        list(
          "actions-box" = !multiple,
          "live-search" = length(choices) > 10,
          "none-selected-text" = "- Nothing selected -",
          "show-subtext" = TRUE
        ),
        args
      )
    )
  )
}

#' Update reactive values with log
#'
#' Update reactive values only if values differ to avoid unnecessary reactive trigger
#' @param rv (`reactiveVal`)
#' @param value (`vector`)
#' @param log (`character(1)`) message to `log_debug`
#' @return the result of `reactiveVal` update if new value is different, `NULL` otherwise.
#' @keywords internal
.update_rv <- function(rv, value, log) {
  if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { # tolerance 1e-15 is a max precision in widgets.
    logger::log_debug(log)
    rv(value)
  }
}

#' Resolve downstream after selected changes
#'
#'  @description
#'  When select input at position `i` changes:
#'   - All slots after position i in `picks_resolved` are reset to their unresolved (delayed) state,
#'     because later slots depend on earlier ones. Slots before and at position i are kept as-is.
#'     For example, changing variables (i=2) resets everything after it but keeps dataset (i=1) intact.
#'   - The new selection replaces the old value at slot i.
#'   - Resolve is called, which evaluates only the slots that are still in an unresolved state.
#'   - The updated picks replace the current `reactiveValue`.
#' Thanks to this design reactive values are triggered only once
#' @param selected (`vector`) rather `character`, or `factor`. `numeric(2)` for `values()` based on numeric column.
#' @param slot_name (`character(1)`) one of `c("datasets", "variables", "values")`
#' @param picks_resolved (`reactiveVal`)
#' @param old_picks (`picks`)
#' @param data (`any` asserted further in `resolver`)
#' @return The result of changing the `picks_resolved` `reactiveVal` given as argument.
#' It returns `NULL` if it does nothing.
#' @keywords internal
.resolve <- function(selected, slot_name, picks_resolved, old_picks, data) {
  checkmate::assert_vector(selected, null.ok = TRUE)
  checkmate::assert_string(slot_name)
  checkmate::assert_class(picks_resolved, "reactiveVal")
  checkmate::assert_class(old_picks, "picks")
  # Input and new selection is the same
  if (isTRUE(all.equal(unclass(selected), unclass(picks_resolved()[[slot_name]]$selected), tolerance = 1e-15))) {
    return(NULL)
  }
  logger::log_info("picks_server@1 selected has changed. Resolving downstream...")

  new_picks_unresolved <- old_picks
  # ↓ everything after `slot_idx` is to resolve
  slot_idx <- which(names(old_picks) == slot_name)
  new_picks_unresolved[seq_len(slot_idx - 1)] <- picks_resolved()[seq_len(slot_idx - 1)]

  if (.is_ranged(selected)) {
    selected <- ranged(selected[1], selected[2])
  }
  new_picks_unresolved[[slot_idx]]$selected <- selected

  resolver_warnings <- character(0)
  new_picks_resolved <- withCallingHandlers(
    resolver(new_picks_unresolved, data),
    warning = function(w) {
      resolver_warnings <<- paste(conditionMessage(w), collapse = " ")
    }
  )
  if (length(resolver_warnings)) {
    showNotification(resolver_warnings, type = "error")
  }

  picks_resolved(new_picks_resolved)
}

#' Restore value from bookmark.
#'
#' Get value from bookmark or return default.
#'
#' Bookmarks can store not only inputs but also arbitrary values.
#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks,
#' and they are placed in the `values` environment in the `session$restoreContext` field.
#' Using `teal_data_module` makes it impossible to run the callbacks
#' because the app becomes ready before modules execute and callbacks are registered.
#' In those cases the stored values can still be recovered from the `session` object directly.
#'
#' Note that variable names in the `values` environment are prefixed with module name space names,
#' therefore, when using this function in modules, `value` must be run through the name space function.
#'
#' @param value (`character(1)`) name of value to restore
#' @param default fallback value
#'
#' @return
#' In an application restored from a server-side bookmark,
#' the variable specified by `value` from the `values` environment.
#' Otherwise `default`.
#'
#' @keywords internal
restoreValue <- function(value, default) { # nolint: object_name.
  checkmate::assert_character("value")
  session_default <- shiny::getDefaultReactiveDomain()
  session_parent <- .subset2(session_default, "parent")
  session <- if (is.null(session_parent)) session_default else session_parent

  if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
    session$restoreContext$values[[value]]
  } else {
    default
  }
}

#' `pickerInput` choices icons
#'
#' Icons describing a class of the choice
#' @param x (`any`) object which class will determine icon
#' @return html-tag in form of `character(1)`
#' @keywords internal
.picker_icon <- function(x) {
  UseMethod(".picker_icon")
}

#' @keywords internal
#' @export
.picker_icon.numeric <- function(x) "arrow-up-1-9"

#' @keywords internal
#' @export
.picker_icon.integer <- function(x) "arrow-up-1-9"

#' @keywords internal
#' @export
.picker_icon.logical <- function(x) "pause"

#' @keywords internal
#' @export
.picker_icon.Date <- function(x) "calendar"

#' @keywords internal
#' @export
.picker_icon.POSIXct <- function(x) "calendar"

#' @keywords internal
#' @export
.picker_icon.POSIXlt <- function(x) "calendar"

#' @keywords internal
#' @export
.picker_icon.factor <- function(x) "chart-bar"

#' @keywords internal
#' @export
.picker_icon.character <- function(x) "font"

#' @keywords internal
#' @export
.picker_icon.primary_key <- function(x) "key"

#' @keywords internal
#' @export
.picker_icon.data.frame <- function(x) "table"

#' @keywords internal
#' @export
.picker_icon.default <- function(x) "circle-question"

#' Merge Server Function for Dataset Integration
#'
#' @description
#' `merge_srv` is a powerful Shiny server function that orchestrates the merging of multiple datasets
#' based on user selections from `picks` objects. It creates a reactive merged dataset (`teal_data` object)
#' and tracks which variables from each selector are included in the final merged output.
#'
#' This function serves as the bridge between user interface selections (managed by selectors) and
#' the actual data merging logic. It automatically handles:
#' - Dataset joining based on join keys
#' - Variable selection and renaming to avoid conflicts
#' - Reactive updates when user selections change
#' - Generation of reproducible R code for the merge operation
#'
#' @param id (`character(1)`) Module ID for the Shiny module namespace
#' @param data (`reactive`) A reactive expression returning a [teal.data::teal_data] object containing
#'   the source datasets to be merged. This object must have join keys defined via
#'   [teal.data::join_keys()] to enable proper dataset relationships.
#' @param selectors (`named list`) A named list of selector objects. Each element can be:
#'   - A `picks` object defining dataset and variable selections
#'   - A `reactive` expression returning a `picks` object
#'   The names of this list are used as identifiers for tracking which variables come from which selector.
#' @param output_name (`character(1)`) Name of the merged dataset that will be created in the
#'   returned `teal_data` object. Default is `"anl"`. This name will be used in the generated R code.
#' @param join_fun (`character(1)`) The joining function to use for merging datasets. Must be a
#'   qualified function name (e.g., `"dplyr::left_join"`, `"dplyr::inner_join"`, `"dplyr::full_join"`).
#'   Default is `"dplyr::inner_join"`. The function must accept `by` and `suffix` parameters.
#'
#' @return A `list` with two reactive elements:
#'  - `data`A `reactive` returning a [teal.data::teal_data] object containing the merged dataset.
#'     The merged dataset is named according to `output_name` parameter. The `teal_data` object includes:
#'     - The merged dataset with all selected variables
#'     - Complete R code to reproduce the merge operation
#'     - Updated join keys reflecting the merged dataset structure
#'  - `variables` A `reactive` returning a named list mapping selector names to their selected
#'     variables in the merged dataset. The structure is:
#'     `list(selector_name_1 = c("var1", "var2"), selector_name_2 = c("var3", "var4"), ...)`.
#'     Variable names reflect any renaming that occurred during the merge to avoid conflicts.
#'
#' @section How It Works:
#'
#' The `merge_srv` function performs the following steps:
#'
#' 1. **Receives Input Data**: Takes a reactive `teal_data` object containing source datasets with
#'    defined join keys
#'
#' 2. **Processes Selectors**: Evaluates each selector (whether static `picks` or reactive) to
#'    determine which datasets and variables are selected
#'
#' 3. **Determines Merge Order**: Uses topological sort based on the `join_keys` to determine
#'    the optimal order for merging datasets.
#'
#' 4. **Handles Variable Conflicts**: Automatically renames variables when:
#'    - Multiple selectors choose variables with the same name from different datasets
#'    - Foreign key variables would conflict with existing variables
#'    - Renaming follows the pattern `{column-name}_{dataset-name}`
#'
#' 5. **Performs Merge**: Generates and executes merge code that:
#'    - Selects only required variables from each dataset
#'    - Applies any filters defined in selectors
#'    - Joins datasets using specified join function and join keys
#'    - Maintains reproducibility through generated R code
#'
#' 6. **Updates Join Keys**: Creates new join key relationships for the merged dataset (`"anl"`)
#'    relative to remaining datasets in the `teal_data` object
#'
#' 7. **Tracks Variables**: Keeps track of the variable names in the merged dataset
#'
#' @section Usage Pattern:
#'
#' ```r
#' # In your Shiny server function
#' merged <- merge_srv(
#'   id = "merge",
#'   data = shiny::reactive(my_teal_data),
#'   selectors = list(
#'     selector1 = picks(...),
#'     selector2 = shiny::reactive(picks(...))
#'   ),
#'   output_name = "anl",
#'   join_fun = "dplyr::left_join"
#' )
#'
#' # Access merged data
#' merged_data <- merged$data()  # teal_data object with merged dataset
#' anl <- merged_data[["anl"]]   # The actual merged data.frame/tibble
#'
#' # Get variable mapping
#' vars <- merged$variables()
#' # Returns: list(selector1 = c("VAR1", "VAR2"), selector2 = c("VAR3", "VAR4_ADSL"))
#'
#' # Get reproducible code
#' code <- teal.code::get_code(merged_data)
#' ```
#'
#' @section Merge Logic Details:
#'
#' **Dataset Order**: Datasets are merged in topological order based on join keys. The first dataset
#' acts as the "left" side of the join, and subsequent datasets are joined one by one.
#'
#' **Join Keys**: The function uses join keys from the source `teal_data` object to determine:
#' - Which datasets can be joined together
#' - Which columns to use for joining (the `by` parameter)
#' - Whether datasets need intermediate joins (not yet implemented)
#'
#' **Variable Selection**: For each dataset being merged:
#' - Selects user-chosen variables from selectors
#' - Includes foreign key variables needed for joining (even if not explicitly selected)
#' - Removes duplicate foreign keys after join (they're already in the left dataset)
#'
#' **Conflict Resolution**: When variable names conflict:
#' - Variables from later datasets get suffixed with `_dataname`
#' - Foreign keys that match are merged (not duplicated)
#' - The mapping returned in `merge_vars` reflects the final names
#'
#' @section Integration with Selectors:
#'
#' `merge_srv` is designed to work with [picks_srv()] which creates selector objects:
#'
#' ```r
#' # Create selectors in server
#' selectors <- picks_srv(
#'   picks =  list(
#'     adsl = picks(...),
#'     adae = picks(...)
#'   ),
#'   data = data
#' )
#'
#' # Pass to merge_srv
#' merged <- merge_srv(
#'   id = "merge",
#'   data = data,
#'   selectors = selectors
#' )
#' ```
#'
#' @seealso
#' - [picks_srv()] for creating selectors
#' - [teal.data::join_keys()] for defining dataset relationships
#'
#' @examples
#' # Complete example with CDISC data
#' library(teal.picks)
#' library(teal.data)
#' library(shiny)
#'
#' # Prepare data with join keys
#' data <- teal_data()
#' data <- within(data, {
#'   ADSL <- teal.data::rADSL
#'   ADAE <- teal.data::rADAE
#' })
#' join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADAE")]
#'
#' # Create Shiny app
#' ui <- fluidPage(
#'   picks_ui("adsl", picks(datasets("ADSL"), variables())),
#'   picks_ui("adae", picks(datasets("ADAE"), variables())),
#'   verbatimTextOutput("code"),
#'   verbatimTextOutput("vars")
#' )
#'
#' server <- function(input, output, session) {
#'   # Create selectors
#'   selectors <- list(
#'     adsl = picks_srv("adsl",
#'       data = shiny::reactive(data),
#'       picks = picks(datasets("ADSL"), variables())
#'     ),
#'     adae = picks_srv("adae",
#'       data = shiny::reactive(data),
#'       picks = picks(datasets("ADAE"), variables())
#'     )
#'   )
#'
#'   # Merge datasets
#'   merged <- merge_srv(
#'     id = "merge",
#'     data = shiny::reactive(data),
#'     selectors = selectors,
#'     output_name = "anl",
#'     join_fun = "dplyr::left_join"
#'   )
#'
#'   # Display results
#'   output$code <- renderPrint({
#'     cat(teal.code::get_code(merged$data()))
#'   })
#'
#'   output$vars <- renderPrint({
#'     merged$variables()
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @export
merge_srv <- function(id,
                      data,
                      selectors,
                      output_name = "anl",
                      join_fun = "dplyr::inner_join") {
  checkmate::assert_list(selectors, "reactive", names = "named")
  checkmate::assert_class(data, "reactive")
  checkmate::assert_string(output_name)
  checkmate::assert_string(join_fun)
  shiny::moduleServer(id, function(input, output, session) {
    # selectors is a list of reactive picks.
    selectors_unwrapped <- shiny::reactive({
      lapply(selectors, function(x) shiny::req(x()))
    })

    data_r <- shiny::reactive({
      shiny::req(data(), selectors_unwrapped())
      .qenv_merge(
        data(),
        selectors = selectors_unwrapped(),
        output_name = output_name,
        join_fun = join_fun
      )
    })

    variables_selected <- shiny::eventReactive(
      selectors_unwrapped(),
      {
        shiny::req(selectors_unwrapped())
        lapply(
          .merge_summary_list(selectors_unwrapped(), join_keys = teal.data::join_keys(data()))$mapping,
          function(selector) unname(selector$variables)
        )
      }
    )

    list(data = data_r, variables = variables_selected)
  })
}


#' @keywords internal
.qenv_merge <- function(x,
                        selectors,
                        output_name = "anl",
                        join_fun = "dplyr::left_join") {
  checkmate::assert_class(x, "teal_data")
  checkmate::assert_list(selectors, "picks", names = "named")
  checkmate::assert_string(join_fun)

  # Early validation of merge keys between datasets
  merge_summary <- .merge_summary_list(selectors, join_keys = teal.data::join_keys(x))

  expr <- .merge_expr(merge_summary = merge_summary, output_name = output_name, join_fun = join_fun, x = x)

  merged_q <- teal.code::eval_code(x, expr)
  teal.data::join_keys(merged_q) <- merge_summary$join_keys
  merged_q
}


#' @keywords internal
.merge_expr <- function(merge_summary,
                        output_name = "anl",
                        join_fun = "dplyr::left_join",
                        x) {
  checkmate::assert_list(merge_summary)
  checkmate::assert_string(output_name)
  checkmate::assert_string(join_fun)

  join_keys <- merge_summary$join_keys
  mapping <- merge_summary$mapping
  mapping <- lapply(mapping, function(x) {
    # because we need `$new_name = $old_name` to rename in select call
    x$variables <- stats::setNames(names(x$variables), unname(x$variables))
    x
  })
  datanames <- unique(unlist(lapply(mapping, `[[`, "datasets")))

  datasets_vars <- .mapping_input_to_datasets(mapping)

  calls <- expression()
  anl_datanames <- character(0) # to follow what anl is composed of (to determine keys)
  anl_primary_keys <- character(0) # to determine accumulated keys of anl
  for (i in seq_along(datanames)) {
    dataname <- datanames[i]
    selectors_dataset <- Filter(function(x) {
      x$datasets == dataname
    }, mapping)
    this_mapping <- datasets_vars[[dataname]]

    this_foreign_keys <- .fk(join_keys, dataname)
    this_primary_keys <- join_keys[dataname, dataname]
    this_variables <- if (length(this_foreign_keys) == 0L) {
      union(this_primary_keys, this_mapping$variables)
    } else {
      union(this_foreign_keys, this_mapping$variables)
    }
    this_variables <- this_variables[!duplicated(unname(this_variables))] # because unique drops names
    operators <- attr(this_mapping, "operators", exact = TRUE)
    operators_names <- vapply(operators, attr, which = "var_name", FUN.VALUE = character(1))
    operators_ix <- this_variables %in% operators_names
    this_call <- if (any(operators_ix)) {
      .call_mutate_operators(this_variables, operators_ix, dataname, operators)
    } else {
      .call_dplyr_select(dataname = dataname, variables = this_variables)
    }

    # Update data with operators to determine filtering on interaction variables
    x <- as.list(x)
    for (ix in which(operators_names %in% this_variables)) {
      x[[dataname]] <- .operator_mutate(operators[[ix]], attr(operators[[ix]], "var_name", TRUE), x[[dataname]])
    }

    selector_filter_dataset <- lapply(selectors_dataset, .trim_filter_mapping, dataname = dataname, data = x)
    filter_datset_value <- vapply(selector_filter_dataset, function(x) {
      !is.null(x$values)
    }, TRUE)
    selector_filter_dataset <- selector_filter_dataset[filter_datset_value & lengths(selector_filter_dataset) > 1L]

    if (length(selector_filter_dataset)) {
      this_call <- calls_combine_by("%>%", c(this_call, .call_dplyr_filter(selector_filter_dataset)))
    }

    if (i > 1) {
      anl_vs_this <- setdiff(anl_primary_keys, this_primary_keys)
      this_vs_anl <- setdiff(this_primary_keys, anl_primary_keys)
      if (length(anl_vs_this) && length(this_vs_anl)) {
        warning("cartesian join - happens when primary keys A is not a subset of B and B is not a subset of A")
      }
      this_call <- as.call(
        list(
          str2lang(join_fun),
          y = this_call,
          by = join_keys["anl", dataname],
          suffix = c("", sprintf("_%s", dataname))
        )
      )
    }

    anl_datanames <- c(anl_datanames, dataname)
    anl_primary_keys <- union(anl_primary_keys, this_primary_keys)
    calls <- c(calls, this_call)
  }

  call("<-", str2lang(output_name), calls_combine_by("%>%", calls))
}


#' Analyse selectors and concludes a merge parameters
#'
#' @return list containing:
#' - mapping (`named list`) containing selected values in each selector. This `mapping`
#'   is sorted according to correct datasets merge order. `variables` contains names of the
#'   variables in `ANL`
#' - join_keys (`join_keys`) updated `join_keys` containing keys of `ANL`
#'
#' @keywords internal
.merge_summary_list <- function(selectors, join_keys) {
  checkmate::assert_list(selectors, "picks")
  checkmate::assert_class(join_keys, "join_keys")

  .validate_is_eager(selectors)
  .validate_join_keys(selectors, join_keys)

  mapping <- lapply( # what has been selected in each selector
    selectors,
    function(selector) {
      result <- lapply(selector, function(x) {
        stats::setNames(x$selected, x$selected)
      })
      result$operators <- selector$variables$operators
      result
    }
  )

  mapped_datanames <- unlist(lapply(mapping, `[[`, "datasets"), use.names = FALSE)
  mapping_by_dataset <- split(mapping, mapped_datanames)

  datanames <- unique(mapped_datanames)
  if (length(datanames) > 1) {
    # datanames are handed over in order of selectors but
    # they must be in topological order - otherwise join might not be possible
    datanames <- c(
      intersect(names(join_keys), datanames), # join_keys are in topological order
      setdiff(datanames, names(join_keys)) # non-joinable datasets at the end
    )

    # mapping will be reused so needs to be reordered as well
    mapping <- mapping[order(match(mapped_datanames, datanames))]
  }
  remaining_datanames <- datanames
  join_keys <- join_keys[datanames]
  anl_colnames <- character(0)
  for (dataname in datanames) {
    #   glossary:
    #     dataset/dataname: dataset (or its name) in the current iteration (datasets are merged in a loop)
    #     anl datasets/datanames: datasets (or names) which anl is composed of (this is a cumulative process)
    #     remaining datasets/datanames: datasets (or names) which are about to be merged
    #
    # Rules:
    #   1. anl "inherits" foreign keys from anl datasets to remaining datasets
    #   2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already.
    #   3. foreign keys should be renamed if duplicated with anl colnames
    #   4. (for later) selected datasets might not be directly mergable, we need to find the "path" which
    #     will probably involve add intermediate datasets in between to perform merge
    #   5. selected variables are added to anl.
    #   6. duplicated variables added to anl should be renamed
    remaining_datanames <- setdiff(remaining_datanames, dataname)

    # ↓  1. anl "inherits" foreign keys from anl datasets to remaining datasets
    this_join_keys <- do.call(
      teal.data::join_keys,
      lapply(
        remaining_datanames,
        function(dataset_2) {
          new_keys <- join_keys[dataname, dataset_2]
          # ↓ 2. foreign keys of current dataset are added to anl join_keys but only if no relation from anl already
          if (length(new_keys) && !dataset_2 %in% names(join_keys[["anl"]])) {
            # ↓ 3. foreign keys should be renamed if duplicated with anl colnames
            new_key_names <- .suffix_duplicated_vars(
              vars = names(new_keys), # names because we change the key of dataset_1 (not dataset_2)
              all_vars = anl_colnames,
              suffix = dataname
            )
            names(new_keys) <- new_key_names
            teal.data::join_key(dataset_1 = "anl", dataset_2 = dataset_2, keys = new_keys)
          }
        }
      )
    )
    join_keys <- c(this_join_keys, join_keys)

    mapping_ds <- mapping_by_dataset[[dataname]]
    mapping_ds <- lapply(mapping_ds, function(x) {
      new_vars <- .suffix_duplicated_vars(
        #       is dropped by merge call. We should refer this selected foreign-key-variable
        #       to equivalent key variable added in previous iteration (existing anl foreign key)
        # 6. duplicated variables added to anl should be renamed
        vars = x$variables,
        all_vars = anl_colnames,
        suffix = dataname
      )

      # if foreign key of this dataset is selected and if this foreign key took a part in the merge
      #  then this key is dropped and we need to refer to the first variable
      existing_fk <- join_keys[dataname, "anl"] # keys that are already in anl
      existing_fk_selected <- intersect(names(existing_fk), x$variables)
      new_vars[existing_fk_selected] <- existing_fk[existing_fk_selected]
      x$variables <- new_vars
      x
    })
    mapping[names(mapping_ds)] <- mapping_ds

    this_colnames <- unique(unlist(lapply(mapping_ds, `[[`, "variables")))
    anl_colnames <- c(anl_colnames, this_colnames)

    anl_colnames <- union(anl_colnames, .fk(join_keys, "anl"))
  }

  list(mapping = mapping, join_keys = join_keys)
}

.fk <- function(x, dataname) {
  this_jk <- x[[dataname]]
  unique(unlist(lapply(this_jk[!names(this_jk) %in% dataname], names)))
}

.suffix_duplicated_vars <- function(vars, all_vars, suffix) {
  names <- names(vars)
  idx_duplicated <- vars %in% all_vars
  if (any(idx_duplicated)) {
    # make sure that names are unchanged!
    vars[idx_duplicated] <- sprintf("%s_%s", vars[idx_duplicated], suffix)
  }
  vars
}

#' Check if datasets can be merged in topological order
#'
#' Determines the topological order from join_keys, then checks that each dataset
#' can be joined with at least one of the previously accumulated datasets.
#'
#' @inheritParams merge_srv
#' @param join_keys (`join_keys`) The join keys object
#' @return `TRUE` if validation passes, otherwise raises a validation
#' error with details on which datasets cannot be merged and why.
#'
#' @keywords internal
.validate_join_keys <- function(selectors, join_keys) {
  validate(need(
    inherits(join_keys, "join_keys"),
    "Provided data doesn't have join_keys specified"
  ))

  datanames <- unique(unlist(lapply(selectors, function(selector) selector$datasets$selected)))
  # No validation needed for single dataset
  if (length(datanames) <= 1) {
    return(TRUE)
  }

  # Get topological order from join_keys (this is the canonical ordering)
  topological_order <- names(join_keys)

  # Filter to only selected datasets and maintain topological order
  ordered_datasets <- intersect(topological_order, datanames)

  # Check if any dataset has no keys defined at all
  if (length(ordered_datasets) != length(datanames)) {
    datasets_without_keys <- setdiff(datanames, ordered_datasets)
    validate(
      need(
        FALSE,
        sprintf(
          "Cannot merge datasets. The following dataset%s no join keys defined: %s.\n\nPlease define `join_keys`.",
          if (length(datasets_without_keys) == 1) " has" else "s have",
          paste(sprintf("'%s'", datasets_without_keys), collapse = ", ")
        )
      )
    )
  }

  # Iteratively check if each dataset can join with accumulated datasets
  accumulated <- ordered_datasets[1]

  for (i in seq(2, length(ordered_datasets))) {
    current_dataset <- ordered_datasets[i]
    can_join <- FALSE

    # Check if current dataset has join keys with ANY accumulated dataset
    for (prev_dataset in accumulated) {
      if (length(join_keys[current_dataset, prev_dataset]) > 0) {
        can_join <- TRUE
        break
      }
    }

    if (!can_join) {
      validate(
        need(
          FALSE,
          sprintf(
            paste(
              "Cannot merge dataset '%s'. No join keys found between '%s' and any of the accumulated datasets:",
              "%s.\n\nPlease define join keys using teal.data::join_keys()."
            ),
            current_dataset,
            current_dataset,
            paste(sprintf("'%s'", accumulated), collapse = ", ")
          )
        )
      )
    }

    # Add current dataset to accumulated
    accumulated <- c(accumulated, current_dataset)
  }

  TRUE
}

.validate_is_eager <- function(x) {
  validate(need(
    !.is_delayed(x),
    "selected values have not been resolved correctly. Please report this issue to an app-developer."
  ))
}

.trim_filter_mapping <- function(mapping, dataname, data) {
  if (is.null(mapping$variables) || is.null(mapping$values)) {
    return(mapping)
  }

  dataset <- data[[dataname]]
  variables <- mapping[["variables"]]
  values <- mapping[["values"]]

  if (length(variables) > 1) {
    # create new temporary variables that pastes together all variables
    dataset <- cbind(".tmp_var" = apply(dataset[, mapping$variables], 1, paste, collapse = ", "))
    dataset <- as.data.frame(dataset)
    variables <- ".tmp_var"
  }

  is_unfiltered <- !.is_ranged(values) && all(dataset[[variables]] %in% values) ||
    .is_ranged(values) && all(
      dataset[[variables]] >= values[[1]] & dataset[[variables]] <= values[[2]]
    )

  if (is_unfiltered) {
    return(list())
  }
  mapping
}

.mapping_input_to_datasets <- function(selectors) {
  datasets <- lapply(selectors, `[[`, "datasets")
  datasets <- unlist(datasets, FALSE, FALSE)

  maps <- vector("list", length = length(unique(datasets)))
  names(maps) <- unique(datasets)

  for (input in selectors) {
    input_dataset <- input$datasets
    if (is.null(maps[[input_dataset]])) {
      maps[[input_dataset]] <- list()
    }

    if (length(input_dataset) > 1L) {
      stop("Multiple datasets for a given input.")
    }

    input_selection <- input[setdiff(names(input), "datasets")]
    if (!is.null(input_selection$variables)) {
      new_variables <- c(maps[[input_dataset]]$variables, input_selection$variables)

      maps[[input_dataset]]$variables <- new_variables[!duplicated(unname(new_variables))]
    }
    if (!is.null(input_selection$values)) {
      new_values <- c(maps[[input_dataset]]$values, input_selection$values)
      maps[[input_dataset]]$values <- new_values[!duplicated(unname(new_values))]
    }
    attr(maps[[input_dataset]], "operators") <- input_selection$operators
  }
  maps
}

#' Merge module
#'
#' Example [`teal::module`] containing interactive inputs and displaying results of merge.
#'
#' @inheritParams teal::module
#' @param picks (`list` of `picks`)
#' @return A `teal::module` object that merges datasets based on user selections and displays the results.
#' @examples
#' library(teal)
#'
#' data <- within(teal.data::teal_data(), {
#'   iris <- iris
#'   mtcars <- mtcars
#' })
#'
#' app <- init(
#'   data = data,
#'   modules = modules(
#'     modules(
#'       label = "Testing modules",
#'       tm_merge(
#'         label = "non adam",
#'         picks = list(
#'           a = picks(
#'             datasets("iris", "iris"),
#'             variables(
#'               choices = c("Sepal.Length", "Species"),
#'               selected = "Sepal.Length"
#'             ),
#'             values()
#'           )
#'         )
#'       )
#'     )
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server, enableBookmarking = "server")
#' }
#'
#' @export
tm_merge <- function(label = "merge-module", picks, transformators = list()) {
  teal::module(
    label = label,
    ui = function(id, picks) {
      ns <- shiny::NS(id)
      tags$div(
        tags$div(
          class = "row g-2",
          lapply(names(picks), function(pick_name) {
            tags$div(
              class = "col-auto",
              tags$strong(tags$label(pick_name)),
              teal.picks::picks_ui(
                id = ns(pick_name),
                picks = picks[[pick_name]]
              )
            )
          })
        ),
        shiny::div(
          shiny::tags$label("Join keys"),
          shiny::verbatimTextOutput(ns("join_keys")),
          shiny::tags$label("Mapped"),
          shiny::verbatimTextOutput(ns("mapped")),
          shiny::tags$label("Source code"),
          shiny::verbatimTextOutput(ns("src")),
          shiny::tags$label("Merge result"),
          shiny::tableOutput(ns("table_merged"))
        )
      )
    },
    server = function(id, data, picks) {
      shiny::moduleServer(id, function(input, output, session) {
        selectors <- picks_srv(id, picks = picks, data = data)

        merged <- merge_srv("merge", data = data, selectors = selectors)

        table_q <- shiny::reactive({
          shiny::req(merged$data())
          within(merged$data(), anl, selectors = selectors)
        })

        output$table_merged <- shiny::renderTable({
          shiny::req(table_q())
          teal.code::get_outputs(table_q())[[1]]
        })

        output$src <- renderPrint({
          cat(teal.code::get_code(shiny::req(table_q())))
        })

        output$mapped <- renderText(yaml::as.yaml(merged$variables()))

        output$join_keys <- renderPrint(teal.data::join_keys(merged$data()))

        table_q
      })
    },
    ui_args = list(picks = picks),
    server_args = list(picks = picks),
    transformators = transformators
  )
}

#' Convert data_extract_spec to picks
#'
#' @description
#' `r lifecycle::badge("experimental")`
#' Helper functions to ease transition between [teal.transform::data_extract_spec()] and [picks()].
#' @inheritParams teal::teal_transform_module
#' @param x (`data_extract_spec`, `select_spec`, `filter_spec`) object to convert to [`picks`]
#' @param quiet (`logical(1)`) whether to suppress warnings about non-convertible elements.
#' @details
#' With introduction of [`picks`], [`data_extract_spec`] will no longer serve a primary tool to
#' define variable choices and default selection in teal-modules and eventually [`data_extract_spec`]
#' will be deprecated.
#' To ease the transition to the new tool, we provide `as.picks` method which can handle 1:1
#' conversion from [`data_extract_spec`] to [`picks`]. Unfortunately, when [`data_extract_spec`]
#' contains [`filter_spec`] then `as.picks` is unable to provide reliable [`picks`] equivalent.
#'
#' @return A `picks` object when conversion is possible, otherwise `NULL` with a warning (if `quiet = FALSE`).
#' @examples
#' # convert des with eager select_spec
#' as.picks(
#'   teal.transform::data_extract_spec(
#'     dataname = "iris",
#'     teal.transform::select_spec(
#'       choices = c("Sepal.Length", "Sepal.Width", "Species"),
#'       selected = c("Sepal.Length", "Species"),
#'       multiple = TRUE,
#'       ordered = TRUE
#'     )
#'   )
#' )
#'
#' # convert des with delayed select_spec
#' as.picks(
#'   teal.transform::data_extract_spec(
#'     dataname = "iris",
#'     teal.transform::select_spec(
#'       choices = teal.transform::variable_choices("iris"),
#'       selected = teal.transform::first_choice(),
#'       multiple = TRUE,
#'       ordered = TRUE
#'     )
#'   )
#' )
#'
#' as.picks(
#'   teal.transform::data_extract_spec(
#'     dataname = "iris",
#'     teal.transform::select_spec(
#'       choices = teal.transform::variable_choices(
#'         "iris",
#'         subset = function(data) names(Filter(is.numeric, data))
#'       ),
#'       selected = teal.transform::first_choice(),
#'       multiple = TRUE,
#'       ordered = TRUE
#'     )
#'   )
#' )
#'
#' @export
as.picks <- function(x, quiet = FALSE) { # nolint: object_name_linter.
  checkmate::assert_flag(quiet)
  if (inherits(x, c("picks", "pick"))) {
    x
  } else if (checkmate::test_list(x, c("data_extract_spec", "filter_spec"))) {
    Filter(length, lapply(x, as.picks, quiet = quiet))
  } else if (inherits(x, "data_extract_spec")) {
    args <- Filter(
      length,
      list(
        datasets(choices = x$dataname, fixed = TRUE),
        as.picks(x$select, quiet = quiet),
        as.picks(x$filter, quiet = quiet)
      )
    )
    do.call(picks, args)
  } else if (inherits(x, "select_spec")) {
    .select_spec_to_variables(x)
  } else if (inherits(x, "choices_selected")) {
    .choices_selected_to_variables(x)
  } else if (inherits(x, "filter_spec") && !quiet) {
    # filter_spec is necessary linked with `select` (selected variables)
    # so  in most of the cases it can't beconverted into variables/values
    # because filter_spec can be specified on the variable(s) different than select_spec for example (pseudocode):
    #    select_spec "AVAL"
    #    filter_spec "PARAMCD"
    warning(
      "`filter_spec` are not convertible to picks - please use `transformers` argument",
      " and create `teal_transform_module` containing necessary filter. See `?teal_transform_filter`"
    )

    NULL
  } else if (!is.null(x) && !quiet) {
    warning(sprintf("'%s' are not convertible to picks", class(x)[1]))
    NULL
  } else {
    NULL
  }
}

#' @rdname as.picks
#' @examples
#' # teal_transform_module build on teal.transform
#'
#' teal_transform_filter(
#'   teal.transform::data_extract_spec(
#'     dataname = "iris",
#'     filter = teal.transform::filter_spec(
#'       vars = "Species",
#'       choices = c("setosa", "versicolor", "virginica"),
#'       selected = c("setosa", "versicolor")
#'     )
#'   )
#' )
#'
#' teal_transform_filter(
#'   picks(
#'     datasets(choices = "iris", select = "iris"),
#'     variables(choices = "Species", "Species"),
#'     values(
#'       choices = c("setosa", "versicolor", "virginica"),
#'       selected = c("setosa", "versicolor")
#'     )
#'   )
#' )
#'
#' @export
teal_transform_filter <- function(x, label = "Filter") {
  checkmate::assert_multi_class(x, c("data_extract_spec", "picks"))
  if (inherits(x, "data_extract_spec")) {
    lapply(.as.picks.filter(x), teal_transform_filter, label = label)
  } else {
    checkmate::assert_true("values" %in% names(x))
    teal::teal_transform_module(
      label = label,
      ui = function(id) {
        ns <- NS(id)
        picks_ui(ns("transformer"), picks = x, container = div)
      },
      server = function(id, data) {
        shiny::moduleServer(id, function(input, output, session) {
          selector <- picks_srv("transformer", picks = x, data = data)
          shiny::reactive({
            shiny::req(data(), selector())
            filter_call <- .make_filter_call(
              datasets = selector()$datasets$selected,
              variables = selector()$variables$selected,
              values = selector()$values$selected
            )
            teal.code::eval_code(data(), filter_call)
          })
        })
      }
    )
  }
}

.as.picks.filter <- function(x, dataname) { # nolint: object_name_linter.
  if (inherits(x, "filter_spec")) {
    if (inherits(x$choices, "delayed_data")) {
      warning(
        "teal.transform::filter_spec(choices) doesn't support delayed_data when using with teal_transform_filter. ",
        "Setting to all possible choices..."
      )
      x$choices <- function(x) TRUE
    }
    if (inherits(x$selected, "delayed_data")) {
      warning(
        "teal.transform::filter_spec(selected) doesn't support delayed_data when using with teal_transform_filter. ",
        "Setting to all possible choices..."
      )
      x$selected <- function(x) TRUE
    }
    picks(
      datasets(choices = dataname, selected = dataname),
      variables(choices = x$vars_choices, selected = x$vars_selected, multiple = FALSE), # can't be multiple
      values(choices = x$choices, selected = x$selected, multiple = x$multiple)
    )
  } else if (checkmate::test_list(x, "filter_spec")) {
    lapply(x, .as.picks.filter, dataname = dataname)
  } else if (inherits(x, "data_extract_spec")) {
    .as.picks.filter(x$filter, dataname = x$dataname)
  } else if (checkmate::test_list(x, c("data_extract_spec", "list", "NULL"))) {
    unlist(
      lapply(Filter(length, x), .as.picks.filter),
      recursive = FALSE
    )
  }
}

.make_filter_call <- function(datasets, variables, values) {
  checkmate::assert_character(datasets)
  checkmate::assert_character(variables)
  checkmate::assert_character(values)
  substitute(
    dataname <- dplyr::filter(dataname, varname %in% values), # nolint: object_usage_linter.
    list(
      dataname = as.name(datasets),
      varname = if (length(variables) == 1) {
        as.name(variables)
      } else {
        as.call(
          c(
            quote(paste),
            lapply(variables, as.name),
            list(sep = ", ")
          )
        )
      },
      values = values
    )
  )
}

.select_spec_to_variables <- function(x) {
  if (length(x)) {
    args <- list(
      choices = if (inherits(x$choices, "delayed_data")) {
        out <- x$choices$subset
        if (is.null(out)) {
          function(x) TRUE # same effect as tidyselect::everything
        } else {
          class(out) <- "des-delayed"
          out
        }
      } else {
        x$choices
      },
      selected = if (inherits(x$selected, "delayed_choices")) {
        out <- x$selected
        class(out) <- "des-delayed"
        out
      } else if (inherits(x$selected, "delayed_data")) {
        out <- x$selected$subset
        if (is.null(out)) {
          1L
        } else {
          class(out) <- "des-delayed"
          out
        }
      } else {
        unname(x$selected)
      },
      ordered = x$ordered,
      multiple = x$multiple,
      fixed = x$fixed
    )
    if (is.null(args$ordered)) { # Must be logical or missing for variables() to set default value
      args <- args[names(args) != c("ordered")]
    }
    do.call(variables, args)
  }
}

.choices_selected_to_variables <- function(x) {
  x$choices <- as.character(x$choices)
  if (!is.null(x$selected)) x$selected <- as.character(x$selected)
  .select_spec_to_variables(x)
}

#' @export
print.pick <- function(x, ...) {
  cat(format(x, indent = 0))
  invisible(x)
}

#' @export
print.picks <- function(x, ...) {
  cat(format(x, indent = 0))
  invisible(x)
}

#' @export
format.picks <- function(x, indent = 0, ...) {
  out <- .indent(sprintf("%s\n", .bold("<picks>")), indent)
  for (i in seq_along(x)) {
    element_name <- names(x)[i]
    out <- paste0(out, .indent(sprintf("  %s:\n", .bold(sprintf("<%s>", element_name))), indent))
    out <- paste0(out, .format_pick_content(x[[i]], indent + 4))
    out <- paste0(out, .format_pick_attributes(x[[i]], indent + 4))
  }
  out
}

#' @export
format.pick <- function(x, indent = 0, ...) {
  element_class <- setdiff(class(x), "pick")[1]
  out <- .indent(sprintf("%s\n", .bold(sprintf("<%s>", element_class))), indent)
  out <- paste0(out, .format_pick_content(x, indent + 2))
  out <- paste0(out, .format_pick_attributes(x, indent + 2))
  out
}

.format_pick_content <- function(x, indent = 0) {
  out <- .indent(sprintf("%s %s\n", "choices:", .format_pick_value(x$choices)), indent)
  out <- paste0(out, .indent(sprintf("%s %s\n", "selected:", .format_pick_value(x$selected)), indent))
  out
}

.format_pick_attributes <- function(x, indent = 0) {
  attrs <- attributes(x)
  attrs_to_show <- attrs[!names(attrs) %in% c("class", "names")]
  if (length(attrs_to_show) > 0) {
    attrs_str <- vapply(names(attrs_to_show), function(name) {
      value <- attrs_to_show[[name]]
      sprintf("%s=%s", name, paste(value, collapse = ","))
    }, character(1))
    paste0(.indent(.italic(paste(attrs_str, collapse = ", ")), indent), "\n")
  } else {
    ""
  }
}

.format_pick_value <- function(x) {
  if (rlang::is_quosure(x) || is.function(x)) {
    rlang::as_label(x)
  } else if (length(x) == 0) {
    "~"
  } else {
    paste(x, collapse = ", ")
  }
}

.indent <- function(x, n) {
  paste(formatC("", width = n), x)
}

.bold <- function(x) {
  sprintf("\033[1m%s\033[0m", x)
}

.italic <- function(x) {
  sprintf("\033[3m%s\033[0m", x)
}

#' Declare interaction variable pairs for `tidyselect`
#'
#' Used inside `tidyselect` expressions to declare a pair of variables that
#' interact with each other. The pair is recorded in the selection environment
#' and the positions of both variables within the available variables are
#' returned.
#'
#' @param var1 An unquoted variable name.
#' @param var2 An unquoted variable name that interacts with `var1`.
#' @param vars Character vector of available variable names, retrieved
#'   automatically via [tidyselect::peek_vars()].
#'
#' @return An integer vector of length 2 giving the positions of `var1` and
#'   `var2` in `vars`, or `NA` where a variable is not found.
#'
#' @export
#' @examples
#' picks(
#'   datasets("ADAE"),
#'   variables(
#'     c(AGE, RACE, interaction_vars("COUNTRY", "RACE")),
#'     selected = "COUNTRY:RACE",
#'     multiple = TRUE
#'   ),
#'   values()
#' )
interaction_vars <- function(var1, var2, vars = tidyselect::peek_vars(fn = "interaction_vars")) {
  new_var <- c(as.character(substitute(var1)), as.character(substitute(var2)))
  result <- match(new_var, vars)
  if (isTRUE(select_env$active)) { # Only set operators under `teal.picks` evaluation context
    new_operator <- structure(
      new_var,
      class = c("interaction", "operator"),
      var_name = sprintf("%s:%s", new_var[[1]], new_var[[2]])
    )
    select_env$operators <- select_env$operators %||% list()
    select_env$operators[[length(select_env$operators) + 1]] <- new_operator
  } else {
    warning(
      "interaction_vars() should only be used within a tidyselect context in teal.picks.",
      " The interaction will not be recorded, and the variables will be treated as independent.",
      call. = FALSE
    )
  }
  result
}

.operator_mutate <- function(x, new_choice, data) {
  UseMethod(".operator_mutate")
}

#' @method .operator_mutate interaction
#' @keywords internal
.operator_mutate.interaction <- function(x, new_choice, data) {
  checkmate::assert_character(x, len = 2)
  checkmate::assert_string(new_choice)
  checkmate::assert_data_frame(data)
  dplyr::mutate(
    data,
    !!new_choice := rlang::eval_bare(.operator_mutate_args(x))
  )
}

#' @method .call_condition_operators interaction
#' @keywords internal
.call_condition_operators.interaction <- function(x, choices) {
  checkmate::assert_character(x, len = 2)
  checkmate::assert_character(choices)
  as.call(
    list(
      quote(`%in%`),
      as.call(
        list(quote(paste), as.name(x[1]), as.name(x[2]), sep = ":")
      ),
      unname(choices)
    )
  )
}

.call_condition_operators <- function(x, choices) {
  UseMethod(".call_condition_operators")
}

.operator_mutate_args <- function(x) {
  UseMethod(".operator_mutate_args")
}

#' @method .operator_mutate interaction
#' @keywords internal
.operator_mutate_args.interaction <- function(x) {
  checkmate::assert_character(x, len = 2)
  as.call(c(list(quote(paste)), lapply(x, as.name), list(sep = ":")))
}


# Environment to store interaction variable pairs during `tidyselect` evaluation
# This is used to communicate between the `interaction_vars()` function and the resolver that
# processes the picks with variables that interact.
# The resolver will look for this information in the environment to know which variables are
# meant to interact and need to be combined in the data.
select_env <- new.env(parent = emptyenv())

.is_operator_selected <- function(operators, x) {
  if (length(operators) == 0L || length(x) == 0L) {
    return(FALSE)
  }
  any(vapply(operators, attr, "var_name", FUN.VALUE = character(1L), USE.NAMES = FALSE) %in% x)
}

#' Helper functions to check pick attributes
#' @description
#' Helper functions for pick objects generated from
#' [datasets()], [variables()] or [values()]:
#' @name helper_functions_pick
#' @param x (`datasets`, `variables` or `values`) pick to check.
#' @return `TRUE` if the pick has the attribute set to `TRUE`,
#' `FALSE` otherwise.
#' @description
#' - `is_pick_multiple()` checks if a pick has the `multiple` attribute set to `TRUE`.
#' @examples
#' p <- picks(datasets("iris"), variables(), values())
#'
#' is_pick_multiple(p$variables)
#' @export
is_pick_multiple <- function(x) {
  checkmate::assert_class(x, classes = c("pick"))
  checkmate::assert_flag(attr(x, "multiple", exact = TRUE))
  isTRUE(attr(x, "multiple", exact = TRUE))
}

#' @rdname helper_functions_pick
#' @description
#' - `is_pick_fixed()` checks if a pick has the `fixed` attribute set to `TRUE`.
#' @examples
#'
#' is_pick_fixed(p$variables)
#' @export
is_pick_fixed <- function(x) {
  checkmate::assert_class(x, classes = c("pick"))
  checkmate::assert_flag(attr(x, "fixed", exact = TRUE))
  isTRUE(attr(x, "fixed", exact = TRUE))
}

#' @rdname helper_functions_pick
#' @description
#' - `is_pick_ordered()` checks if a pick has the `ordered` attribute set to `TRUE`.
#' @examples
#'
#' is_pick_ordered(p$variables)
#' @export
is_pick_ordered <- function(x) {
  checkmate::assert_class(x, classes = c("pick"))
  checkmate::assert_flag(attr(x, "ordered", exact = TRUE))
  isTRUE(attr(x, "ordered", exact = TRUE))
}

#' Assert level
#'
#' @param x `picks` object
#' @param class Class of the last element of picks
#' @inheritParams checkmate::makeAssertionFunction
#' @inheritParams checkmate::assert
#' @rdname assert_last_level
#' @returns For `check_last_level` a logical value or a string.
#' For `assert_last_level` invisibly the object checked or an error.
#' @export
#' @examples
#' x <- picks(datasets(), variables(), values())
#' assert_last_level(x, "values")
check_last_level <- function(x, class) {
  checkmate::assert_character(class, len = 1, any.missing = FALSE)
  check <- inherits(x, "picks") && inherits(x[[length(x)]], class)
  if (isFALSE(check)) {
    return(sprintf("This is not a picks object that ends in %s", class))
  }
  check
}

#' @export
#' @rdname assert_last_level
assert_last_level <- checkmate::makeAssertionFunction(check_last_level)

.onLoad <- function(libname, pkgname) { # nolint
  # Set up the teal logger instance
  teal.logger::register_logger("teal.slice")
  teal.logger::register_handlers("teal.slice")

  # Manual import instead of using backports and adding 1 more dependency
  if (getRversion() < "4.4") {
    assign("%||%", rlang::`%||%`, envir = getNamespace(pkgname))
  }

  invisible()
}

#' Drop-down badge
#'
#' Drop-down button in a form of a badge with `bg-primary` as default style
#' Clicking badge shows a drop-down containing any `HTML` element. Folded drop-down
#' doesn't trigger display output which means that items rendered using `render*`
#' will be recomputed only when drop-down is show.
#'
#' @param id (`character(1)`) shiny module's id
#' @param label (`shiny.tag`) Label displayed on a badge.
#' @param content (`shiny.tag`) Content of a drop-down.
#' @return A `shiny.tag` object representing a drop-down badge component to display the options.
#' @keywords internal
badge_dropdown <- function(id, label, content) {
  ns <- shiny::NS(id)
  htmltools::tagList(
    htmltools::singleton(htmltools::tags$head(
      htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.picks")),
      htmltools::includeScript(system.file("badge-dropdown", "script.js", package = "teal.picks"))
    )),
    htmltools::tags$div(
      class = "badge-wrapper",
      htmltools::tags$span(
        id = ns("summary_badge"),
        class = "badge bg-primary rounded-pill badge-dropdown",
        style = "cursor: pointer;",
        tags$span(class = "badge-dropdown-label", label),
        tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")),
        onclick = sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container"))
      ),
      htmltools::tags$div(
        content,
        id = ns("inputs_container"),
        style = htmltools::css(
          visibility = "hidden",
          width = "0",
          position = "fixed",
          background = "white",
          border = "1px solid #ccc",
          `border-radius` = "4px",
          `box-shadow` = "0 2px 10px rgba(0,0,0,0.1)",
          padding = "10px",
          `z-index` = "1050", # z-index set to 1000+50 to ensure that is above encoding panel on 1 column layout.
          `min-width` = "200px",
          transition = "opacity 0.2s ease",
          opacity = 0
        )
      )
    )
  )
}

#' Fixed badge
#' @inheritParams badge_dropdown
#' @return A `shiny.tag` object representing a fixed badge component to display the selected option.
#' @keywords internal
badge_fixed <- function(id, label, content) {
  ns <- shiny::NS(id)

  htmltools::tagList(
    htmltools::singleton(htmltools::tags$head(
      htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.picks"))
    )),
    htmltools::tags$div(
      class = "badge-wrapper",
      htmltools::tags$span(
        id = ns("fixed_badge"),
        class = "fixed-picks badge-dropdown",
        htmltools::tags$label(label),
        htmltools::tags$i(bsicons::bs_icon("lock-fill"))
      ),
      htmltools::tags$div(
        id = ns("inputs_container"),
        class = "zero-width-inputs",
        content,
        style = "visibility: hidden; width: 0; height: 0; position: fixed;"
      )
    )
  )
}

1		#' `tidyselect` helpers
2		#'
3		#' @description
4		#' #' `r lifecycle::badge("experimental")`
5		#' Predicate functions simplifying `picks` specification.
6		#' @examples
7		#' # select factor column but exclude foreign keys
8		#' variables(choices = is_categorical(min.len = 2, max.len = 10))
9		#'
10		#' @name tidyselectors
11		#' @rdname tidyselectors
12		#' @param min.len (`integer(1)`) minimal number of unique values
13		#' @param max.len (`integer(1)`) maximal number of unique values
14		#' @return A `tidyselector` that can be used directly in `choices` or `selected` of `variables()` in `picks()`.
15		#' @export
16		#' @examples
17		#' # Supports tidyselect helpers, e.g. to select all categorical variables with 2 to 10 unique values
18		#' dplyr::select(iris, dplyr::where(is_categorical(2, 10)))
19		#'
20		#' p <- picks(
21		#' datasets(is.data.frame, 2L),
22		#' variables(is_categorical(2, 10))
23		#' )
24		#' resolver(data = list(mtcars = mtcars, iris = iris), x = p)
25		is_categorical <- function(min.len, max.len) {
26		# todo: consider making a function which can exit earlier when max.len > length(unique(x)) < min.len
27		# without a need to compute unique on the whole vector.
28	8x	if (missing(max.len) && missing(min.len)) {
29	1x	function(x) is.factor(x) \|\| is.character(x)
30	7x	} else if (!missing(max.len) && missing(min.len)) {
31	2x	checkmate::assert_int(max.len, lower = 0)
32	1x	function(x) (is.factor(x) \|\| is.character(x)) && length(unique(x)) <= max.len
33	5x	} else if (!missing(min.len) && missing(max.len)) {
34	2x	checkmate::assert_int(min.len, lower = 0)
35	1x	function(x) (is.factor(x) \|\| is.character(x)) && length(unique(x)) >= min.len
36		} else {
37	3x	checkmate::assert_int(min.len, lower = 0)
38	3x	checkmate::assert_int(max.len, lower = 0)
39	3x	checkmate::assert_true(max.len >= min.len)
40	2x	function(x) {
41	6x	(is.factor(x) \|\| is.character(x)) && {
42	5x	n <- length(unique(x))
43	5x	n >= min.len && n <= max.len
44		}
45		}
46		}
47		}
48
49
50		#' Select a range
51		#'
52		#' Helper to work with ranges. Setting `choices` or `selected` to range using
53		#' `ranged()` in any of them will automatically create a `numeric`, `Date` or `POSIXct`
54		#' input to filter. `variables(choices)` must only refer to `numeric`, `Date`, or `POSIXct`
55		#' columns. An informative error is raised if the resolved column type is unsupported.
56		#' @param min (`numeric(1)`) Minimal value.
57		#' @param max (`numeric(1)`) Maximal value.
58		#' @return A function that allows the use of a range in `choices` or `selected` of `values()` in
59		#' `numeric`, `Date`, or `POSIXct` variables.
60		#' @export
61		#' @examples
62		#' p <- picks(
63		#' datasets(choices = "mtcars"),
64		#' variables(choices = is.numeric, selected = 1),
65		#' values(choices = ranged(), ranged(20, 30))
66		#' )
67		#' resolver(data = list("mtcars label" = mtcars), x = p)
68		ranged <- function(min = -Inf, max = Inf) {
69	23x	checkmate::assert_number(min)
70	21x	checkmate::assert_number(max)
71	19x	if (min > max) {
72	1x	stop("`min` must be lower than `max`")
73		}
74	18x	.as_ranged(
75	18x	function(x) {
76	102x	!is.na(x) & x <= max & x >= min
77		}
78		)
79		}
80
81		#' Check if choices/selected is a range.
82		#'
83		#' @noRd
84		.is_ranged <- function(x) {
85	210x	inherits(x, "ranged")
86		}
87
88		#' Set "ranged" class to the object. Be watchful as
89		#' it is used in two contexts.
90		#' 1. Unresolved range in `values`'s `choices` and `selected` - setting a range predicate to
91		#' be resolved in `determine`
92		#' 2. Resolved range - sets a class to the `choices` and `selected` to inform that resolved vector
93		#' is a range, to show a `numericRangeInput` and to filter values by `lower >= x <= upper`
94		#'
95		#' @noRd
96		.as_ranged <- function(x) {
97	38x	class(x) <- c(class(x), "ranged")
98	38x	x
99		}

1		#' Merge module
2		#'
3		#' Example [`teal::module`] containing interactive inputs and displaying results of merge.
4		#'
5		#' @inheritParams teal::module
6		#' @param picks (`list` of `picks`)
7		#' @return A `teal::module` object that merges datasets based on user selections and displays the results.
8		#' @examples
9		#' library(teal)
10		#'
11		#' data <- within(teal.data::teal_data(), {
12		#' iris <- iris
13		#' mtcars <- mtcars
14		#' })
15		#'
16		#' app <- init(
17		#' data = data,
18		#' modules = modules(
19		#' modules(
20		#' label = "Testing modules",
21		#' tm_merge(
22		#' label = "non adam",
23		#' picks = list(
24		#' a = picks(
25		#' datasets("iris", "iris"),
26		#' variables(
27		#' choices = c("Sepal.Length", "Species"),
28		#' selected = "Sepal.Length"
29		#' ),
30		#' values()
31		#' )
32		#' )
33		#' )
34		#' )
35		#' )
36		#' )
37		#' if (interactive()) {
38		#' shinyApp(app$ui, app$server, enableBookmarking = "server")
39		#' }
40		#'
41		#' @export
42		tm_merge <- function(label = "merge-module", picks, transformators = list()) {
43	19x	teal::module(
44	19x	label = label,
45	19x	ui = function(id, picks) {
46	7x	ns <- shiny::NS(id)
47	7x	tags$div(
48	7x	tags$div(
49	7x	class = "row g-2",
50	7x	lapply(names(picks), function(pick_name) {
51	9x	tags$div(
52	9x	class = "col-auto",
53	9x	tags$strong(tags$label(pick_name)),
54	9x	teal.picks::picks_ui(
55	9x	id = ns(pick_name),
56	9x	picks = picks[[pick_name]]
57		)
58		)
59		})
60		),
61	7x	shiny::div(
62	7x	shiny::tags$label("Join keys"),
63	7x	shiny::verbatimTextOutput(ns("join_keys")),
64	7x	shiny::tags$label("Mapped"),
65	7x	shiny::verbatimTextOutput(ns("mapped")),
66	7x	shiny::tags$label("Source code"),
67	7x	shiny::verbatimTextOutput(ns("src")),
68	7x	shiny::tags$label("Merge result"),
69	7x	shiny::tableOutput(ns("table_merged"))
70		)
71		)
72		},
73	19x	server = function(id, data, picks) {
74	5x	shiny::moduleServer(id, function(input, output, session) {
75	5x	selectors <- picks_srv(id, picks = picks, data = data)
76
77	5x	merged <- merge_srv("merge", data = data, selectors = selectors)
78
79	5x	table_q <- shiny::reactive({
80	4x	shiny::req(merged$data())
81	4x	within(merged$data(), anl, selectors = selectors)
82		})
83
84	5x	output$table_merged <- shiny::renderTable({
85	3x	shiny::req(table_q())
86	3x	teal.code::get_outputs(table_q())[[1]]
87		})
88
89	5x	output$src <- renderPrint({
90	3x	cat(teal.code::get_code(shiny::req(table_q())))
91		})
92
93	5x	output$mapped <- renderText(yaml::as.yaml(merged$variables()))
94
95	5x	output$join_keys <- renderPrint(teal.data::join_keys(merged$data()))
96
97	5x	table_q
98		})
99		},
100	19x	ui_args = list(picks = picks),
101	19x	server_args = list(picks = picks),
102	19x	transformators = transformators
103		)
104		}

1		#' @export
2		print.pick <- function(x, ...) {
3	4x	cat(format(x, indent = 0))
4	4x	invisible(x)
5		}
6
7		#' @export
8		print.picks <- function(x, ...) {
9	2x	cat(format(x, indent = 0))
10	2x	invisible(x)
11		}
12
13		#' @export
14		format.picks <- function(x, indent = 0, ...) {
15	3x	out <- .indent(sprintf("%s\n", .bold("<picks>")), indent)
16	3x	for (i in seq_along(x)) {
17	5x	element_name <- names(x)[i]
18	5x	out <- paste0(out, .indent(sprintf(" %s:\n", .bold(sprintf("<%s>", element_name))), indent))
19	5x	out <- paste0(out, .format_pick_content(x[[i]], indent + 4))
20	5x	out <- paste0(out, .format_pick_attributes(x[[i]], indent + 4))
21		}
22	3x	out
23		}
24
25		#' @export
26		format.pick <- function(x, indent = 0, ...) {
27	9x	element_class <- setdiff(class(x), "pick")[1]
28	9x	out <- .indent(sprintf("%s\n", .bold(sprintf("<%s>", element_class))), indent)
29	9x	out <- paste0(out, .format_pick_content(x, indent + 2))
30	9x	out <- paste0(out, .format_pick_attributes(x, indent + 2))
31	9x	out
32		}
33
34		.format_pick_content <- function(x, indent = 0) {
35	14x	out <- .indent(sprintf("%s %s\n", "choices:", .format_pick_value(x$choices)), indent)
36	14x	out <- paste0(out, .indent(sprintf("%s %s\n", "selected:", .format_pick_value(x$selected)), indent))
37	14x	out
38		}
39
40		.format_pick_attributes <- function(x, indent = 0) {
41	14x	attrs <- attributes(x)
42	14x	attrs_to_show <- attrs[!names(attrs) %in% c("class", "names")]
43	14x	if (length(attrs_to_show) > 0) {
44	14x	attrs_str <- vapply(names(attrs_to_show), function(name) {
45	45x	value <- attrs_to_show[[name]]
46	45x	sprintf("%s=%s", name, paste(value, collapse = ","))
47	14x	}, character(1))
48	14x	paste0(.indent(.italic(paste(attrs_str, collapse = ", ")), indent), "\n")
49		} else {
50		""
51		}
52		}
53
54		.format_pick_value <- function(x) {
55	28x	if (rlang::is_quosure(x) \|\| is.function(x)) {
56	4x	rlang::as_label(x)
57	24x	} else if (length(x) == 0) {
58		"~"
59		} else {
60	24x	paste(x, collapse = ", ")
61		}
62		}
63
64		.indent <- function(x, n) {
65	59x	paste(formatC("", width = n), x)
66		}
67
68		.bold <- function(x) {
69	17x	sprintf("\033[1m%s\033[0m", x)
70		}
71
72		.italic <- function(x) {
73	14x	sprintf("\033[3m%s\033[0m", x)
74		}

1		#' Declare interaction variable pairs for `tidyselect`
2		#'
3		#' Used inside `tidyselect` expressions to declare a pair of variables that
4		#' interact with each other. The pair is recorded in the selection environment
5		#' and the positions of both variables within the available variables are
6		#' returned.
7		#'
8		#' @param var1 An unquoted variable name.
9		#' @param var2 An unquoted variable name that interacts with `var1`.
10		#' @param vars Character vector of available variable names, retrieved
11		#' automatically via [tidyselect::peek_vars()].
12		#'
13		#' @return An integer vector of length 2 giving the positions of `var1` and
14		#' `var2` in `vars`, or `NA` where a variable is not found.
15		#'
16		#' @export
17		#' @examples
18		#' picks(
19		#' datasets("ADAE"),
20		#' variables(
21		#' c(AGE, RACE, interaction_vars("COUNTRY", "RACE")),
22		#' selected = "COUNTRY:RACE",
23		#' multiple = TRUE
24		#' ),
25		#' values()
26		#' )
27		interaction_vars <- function(var1, var2, vars = tidyselect::peek_vars(fn = "interaction_vars")) {
28	7x	new_var <- c(as.character(substitute(var1)), as.character(substitute(var2)))
29	7x	result <- match(new_var, vars)
30	4x	if (isTRUE(select_env$active)) { # Only set operators under `teal.picks` evaluation context
31	3x	new_operator <- structure(
32	3x	new_var,
33	3x	class = c("interaction", "operator"),
34	3x	var_name = sprintf("%s:%s", new_var[[1]], new_var[[2]])
35		)
36	3x	select_env$operators <- select_env$operators %\|\|% list()
37	3x	select_env$operators[[length(select_env$operators) + 1]] <- new_operator
38		} else {
39	1x	warning(
40	1x	"interaction_vars() should only be used within a tidyselect context in teal.picks.",
41	1x	" The interaction will not be recorded, and the variables will be treated as independent.",
42	1x	call. = FALSE
43		)
44		}
45	4x	result
46		}
47
48		.operator_mutate <- function(x, new_choice, data) {
49	2x	UseMethod(".operator_mutate")
50		}
51
52		#' @method .operator_mutate interaction
53		#' @keywords internal
54		.operator_mutate.interaction <- function(x, new_choice, data) {
55	2x	checkmate::assert_character(x, len = 2)
56	2x	checkmate::assert_string(new_choice)
57	2x	checkmate::assert_data_frame(data)
58	2x	dplyr::mutate(
59	2x	data,
60	2x	!!new_choice := rlang::eval_bare(.operator_mutate_args(x))
61		)
62		}
63
64		#' @method .call_condition_operators interaction
65		#' @keywords internal
66		.call_condition_operators.interaction <- function(x, choices) {
67	1x	checkmate::assert_character(x, len = 2)
68	1x	checkmate::assert_character(choices)
69	1x	as.call(
70	1x	list(
71	1x	quote(`%in%`),
72	1x	as.call(
73	1x	list(quote(paste), as.name(x[1]), as.name(x[2]), sep = ":")
74		),
75	1x	unname(choices)
76		)
77		)
78		}
79
80		.call_condition_operators <- function(x, choices) {
81	1x	UseMethod(".call_condition_operators")
82		}
83
84		.operator_mutate_args <- function(x) {
85	2x	UseMethod(".operator_mutate_args")
86		}
87
88		#' @method .operator_mutate interaction
89		#' @keywords internal
90		.operator_mutate_args.interaction <- function(x) {
91	2x	checkmate::assert_character(x, len = 2)
92	2x	as.call(c(list(quote(paste)), lapply(x, as.name), list(sep = ":")))
93		}
94
95
96		# Environment to store interaction variable pairs during `tidyselect` evaluation
97		# This is used to communicate between the `interaction_vars()` function and the resolver that
98		# processes the picks with variables that interact.
99		# The resolver will look for this information in the environment to know which variables are
100		# meant to interact and need to be combined in the data.
101		select_env <- new.env(parent = emptyenv())
102
103		.is_operator_selected <- function(operators, x) {
104	1x	if (length(operators) == 0L \|\| length(x) == 0L) {
105	!	return(FALSE)
106		}
107	1x	any(vapply(operators, attr, "var_name", FUN.VALUE = character(1L), USE.NAMES = FALSE) %in% x)
108		}

1		#' Drop-down badge
2		#'
3		#' Drop-down button in a form of a badge with `bg-primary` as default style
4		#' Clicking badge shows a drop-down containing any `HTML` element. Folded drop-down
5		#' doesn't trigger display output which means that items rendered using `render*`
6		#' will be recomputed only when drop-down is show.
7		#'
8		#' @param id (`character(1)`) shiny module's id
9		#' @param label (`shiny.tag`) Label displayed on a badge.
10		#' @param content (`shiny.tag`) Content of a drop-down.
11		#' @return A `shiny.tag` object representing a drop-down badge component to display the options.
12		#' @keywords internal
13		badge_dropdown <- function(id, label, content) {
14	3x	ns <- shiny::NS(id)
15	3x	htmltools::tagList(
16	3x	htmltools::singleton(htmltools::tags$head(
17	3x	htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.picks")),
18	3x	htmltools::includeScript(system.file("badge-dropdown", "script.js", package = "teal.picks"))
19		)),
20	3x	htmltools::tags$div(
21	3x	class = "badge-wrapper",
22	3x	htmltools::tags$span(
23	3x	id = ns("summary_badge"),
24	3x	class = "badge bg-primary rounded-pill badge-dropdown",
25	3x	style = "cursor: pointer;",
26	3x	tags$span(class = "badge-dropdown-label", label),
27	3x	tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")),
28	3x	onclick = sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container"))
29		),
30	3x	htmltools::tags$div(
31	3x	content,
32	3x	id = ns("inputs_container"),
33	3x	style = htmltools::css(
34	3x	visibility = "hidden",
35	3x	width = "0",
36	3x	position = "fixed",
37	3x	background = "white",
38	3x	border = "1px solid #ccc",
39	3x	`border-radius` = "4px",
40	3x	`box-shadow` = "0 2px 10px rgba(0,0,0,0.1)",
41	3x	padding = "10px",
42	3x	`z-index` = "1050", # z-index set to 1000+50 to ensure that is above encoding panel on 1 column layout.
43	3x	`min-width` = "200px",
44	3x	transition = "opacity 0.2s ease",
45	3x	opacity = 0
46		)
47		)
48		)
49		)
50		}
51
52		#' Fixed badge
53		#' @inheritParams badge_dropdown
54		#' @return A `shiny.tag` object representing a fixed badge component to display the selected option.
55		#' @keywords internal
56		badge_fixed <- function(id, label, content) {
57	10x	ns <- shiny::NS(id)
58
59	10x	htmltools::tagList(
60	10x	htmltools::singleton(htmltools::tags$head(
61	10x	htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.picks"))
62		)),
63	10x	htmltools::tags$div(
64	10x	class = "badge-wrapper",
65	10x	htmltools::tags$span(
66	10x	id = ns("fixed_badge"),
67	10x	class = "fixed-picks badge-dropdown",
68	10x	htmltools::tags$label(label),
69	10x	htmltools::tags$i(bsicons::bs_icon("lock-fill"))
70		),
71	10x	htmltools::tags$div(
72	10x	id = ns("inputs_container"),
73	10x	class = "zero-width-inputs",
74	10x	content,
75	10x	style = "visibility: hidden; width: 0; height: 0; position: fixed;"
76		)
77		)
78		)
79		}

1		#' Resolve `picks`
2		#'
3		#' Resolve iterates through each `picks` element and determines values .
4		#' @param x ([picks()]) settings for picks.
5		#' @param data ([teal_data()] `environment` or `list`) any data collection supporting object extraction with `[[`.
6		#' Used to determine values of unresolved `picks`.
7		#'
8		#' @returns resolved `picks`.
9		#' @export
10		#'
11		#' @examples
12		#' x <- picks(datasets(tidyselect::where(is.data.frame)), variables("a", "a"))
13		#' data <- list(
14		#' df1 = data.frame(a = as.factor(LETTERS[1:5]), b = letters[1:5]),
15		#' df2 = data.frame(a = LETTERS[1:5], b = 1:5),
16		#' m = matrix()
17		#' )
18		#' resolver(x = x, data = data)
19		resolver <- function(x, data) {
20	78x	checkmate::assert_class(x, "picks")
21	78x	checkmate::assert(
22	78x	is.environment(data),
23	78x	checkmate::check_list(data, names = "unique")
24		)
25	75x	data_i <- data
26	75x	for (i in seq_along(x)) {
27	153x	determined_i <- determine(x[[i]], data = data_i)
28	153x	data_i <- determined_i$data
29	153x	x[[i]] <- determined_i$x
30		}
31	75x	x
32		}
33
34		#' A method that should take a type and resolve it.
35		#'
36		#' Generic that makes the minimal check on spec.
37		#' Responsible of subsetting/extract the data received and check that the type matches
38		#' @param x The specification to resolve.
39		#' @param data The minimal data required.
40		#' @return A list with two elements, the `type` resolved and the data extracted.
41		#' @keywords internal
42		determine <- function(x, data) {
43	223x	if (is.null(data)) { # this happens when <previous>$selected=NULL
44	4x	return(list(x = .nullify_pick(x)))
45		}
46	219x	UseMethod("determine")
47		}
48
49		#' @export
50		determine.datasets <- function(x, data) {
51	110x	checkmate::assert(is.environment(data), is.list(data))
52	110x	data <- as.list(data)
53	110x	x$choices <- .determine_choices(x = x$choices, data = data)
54	110x	x$selected <- .determine_selected(
55	110x	x = x$selected,
56	110x	data = data[intersect(x$choices, names(data))],
57	110x	multiple = attr(x, "multiple")
58		)
59	110x	list(x = x, data = .extract(x, data))
60		}
61
62		#' @export
63		determine.variables <- function(x, data) {
64	82x	checkmate::assert_multi_class(data, c("data.frame", "tbl_df", "data.table", "DataFrame"))
65	82x	if (ncol(data) <= 0L) {
66	1x	warning("Selected dataset has no columns", call. = FALSE)
67	1x	return(list(x = .nullify_pick(x)))
68		}
69
70	81x	old <- select_env$operators
71	81x	select_env$active <- TRUE
72	81x	on.exit(select_env$operators <- old, add = TRUE)
73	81x	on.exit(select_env$active <- FALSE, add = TRUE)
74
75	81x	x$choices <- .determine_choices(x$choices, data = data)
76		# change data to add columns that combine interaction vars
77	81x	custom_operators <- unique(select_env$operators) %\|\|% x$operators
78
79	81x	for (ix in seq_along(custom_operators)) {
80	1x	new_choice <- rlang::set_names(attr(custom_operators[[ix]], "var_name", TRUE))
81	1x	data <- .operator_mutate(custom_operators[[ix]], new_choice, data)
82	1x	x$choices <- c(x$choices, new_choice)
83	1x	x$operators <- custom_operators
84		}
85
86	81x	x$selected <- .determine_selected(
87	81x	x$selected,
88	81x	data = data[intersect(x$choices, colnames(data))],
89	81x	multiple = attr(x, "multiple")
90		)
91	81x	list(x = x, data = .extract(x, data))
92		}
93
94		#' @export
95		determine.values <- function(x, data) {
96	27x	data <- if (ncol(data) > 1) {
97	3x	apply(data, 1, toString)
98		} else {
99	24x	data[[1]]
100		}
101
102	27x	data <- stats::setNames(unique(data), unique(data))
103	27x	is_ranged <- if (.is_ranged(x$choices) \|\| .is_ranged(x$selected)) {
104	12x	TRUE
105		} else {
106	15x	FALSE
107		}
108
109	27x	if (is_ranged && !is.numeric(data) && !inherits(data, c("Date", "POSIXct"))) {
110	!	warning(
111	!	"Column used with `ranged()` must be numeric, Date, or POSIXct, but got: ",
112	!	paste(class(data), collapse = "/"),
113	!	". Please adjust `variables(choices)` to only select supported column types.",
114	!	call. = FALSE
115		)
116	!	x$choices <- NULL
117	!	x$selected <- NULL
118	!	return(list(x = x))
119		}
120
121	27x	x$choices <- .determine_choices(x$choices, data = data) # .determine_* uses names
122	27x	x$selected <- if (length(x$choices)) {
123	23x	.determine_selected(x$selected, data = stats::setNames(x$choices, x$choices), multiple = attr(x, "multiple"))
124		}
125
126		# Only return max and minimal value
127	27x	if (is_ranged) {
128	12x	if (!is.null(x$choices)) {
129	10x	x$choices <- .as_ranged(x$choices)
130		}
131	12x	if (!is.null(x$selected)) {
132	10x	x$selected <- .as_ranged(range(x$selected, na.rm = TRUE))
133		}
134		}
135
136	27x	list(x = x) # no picks element possible after picks(..., values) (no need to pass data further)
137		}
138
139
140		#' Evaluate delayed choices
141		#'
142		#' @param data (`list`, `data.frame`, `vector`)
143		#' @param x (`character`, `quosure`, `function(x)`) to determine `data` elements to extract.
144		#' @param multiple (`logical(1)`) whether multiple selection is possible.
145		#'
146		#' @details
147		#'
148		#' ## Various ways to evaluate choices/selected.
149		#'
150		#' Function resolves `x` to determine `choices` or `selected`. `x` is matched in multiple ways with
151		#' `data` to return valid choices:
152		#' - `x (character)`: values are matched with names of data and only intersection is returned.
153		#' - `x (tidyselect-helper)`: using [tidyselect::eval_select]
154		#' - `x (function)`: function is executed on each element of `data` to determine where function returns TRUE
155		#'
156		#' Mechanism is robust in a sense that it never fails (`tryCatch`) and returns `NULL` if no-match found. `NULL`
157		#' in [determine()] is handled gracefully, by setting `NULL` to all following components of `picks`.
158		#'
159		#' In the examples below you can replace `.determine_delayed` with `.determine_choices` or `.determine_selected`.
160		#'
161		#' - `character`: refers to the object name in `data`, for example
162		#' ```
163		#' .determine_delayed(data = iris, x = "Species")
164		#' .determine_delayed(data = iris, x = c("Species", "inexisting"))
165		#' .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars)), x = "iris")
166		#' ```
167		#' - `quosure`: delayed (quoted) `tidyselect-helper` to be evaluated through `tidyselect::eval_select`. For example
168		#' ```
169		#' .determine_delayed(data = iris, x = rlang::quo(tidyselect::starts_with("Sepal")))
170		#' .determine_delayed(data = iris, x = rlang::quo(1:2))
171		#' .determine_delayed(data = iris, x = rlang::quo(Petal.Length:Sepal.Length))
172		#' ```
173		#' - `function(x)`: predicate function returning a logical flag. Evaluated for each `data` element. For example
174		#' ```
175		#'
176		#' .determine_delayed(data = iris, x = is.numeric)
177		#' .determine_delayed(data = letters, x = function(x) x > "c")
178		#' .determine_delayed(data = list2env(list(iris = iris, mtcars = mtcars, a = "a")), x = is.data.frame)
179		#' ```
180		#'
181		#' @return `character` containing names/levels of `data` elements which match `x`, with two differences:
182		#' - `.determine_choices` returns vector named after data labels
183		#' - `.determine_selected` cuts vector to scalar when `multiple = FALSE`
184		#'
185		#' @keywords internal
186		.determine_choices <- function(x, data) {
187	218x	out <- .determine_delayed(data = data, x = x)
188	218x	if (!is.null(names(data)) && !is.atomic(data) && is.character(out) && is.null(names(out))) {
189		# only named non-atomic can have label
190		# don't rename if names provided by app dev
191	153x	labels <- vapply(
192	153x	out,
193	153x	FUN = function(choice) c(attr(data[[choice]], "label"), choice)[1],
194	153x	FUN.VALUE = character(1)
195		)
196	153x	stats::setNames(out, labels)
197		} else {
198	65x	out
199		}
200		}
201
202		#' @rdname dot-determine_choices
203		.determine_selected <- function(x, data, multiple = FALSE) {
204	214x	if (!is.null(x) && length(data)) {
205	213x	out <- .determine_delayed(data = data, x = x)
206	213x	if (!isTRUE(multiple) && length(out) > 1) {
207	1x	warning(
208	1x	"`multiple` has been set to `FALSE`, while selected contains multiple values, forcing to select first:",
209	1x	rlang::as_label(x)
210		)
211	1x	out <- out[1]
212		}
213	213x	out
214		}
215		}
216
217		#' @rdname dot-determine_choices
218		.determine_delayed <- function(x, data) {
219	431x	if (length(dim(data)) == 2L) { # for example matrix
220	161x	data <- as.data.frame(data)
221		}
222	431x	out <- tryCatch( # app developer might provide failing function
223	431x	if (is.atomic(x) && length(x)) {
224		# don't need to evaluated eager choices - just make sure choices are subset of possible
225	292x	x[which(x %in% .possible_choices(data))]
226	431x	} else if (is.function(x)) {
227	47x	if (inherits(x, "des-delayed")) {
228	2x	x(data)
229		} else {
230	45x	idx_match <- unique(which(vapply(data, x, logical(1))))
231	45x	.possible_choices(data[idx_match])
232		}
233	431x	} else if (rlang::is_quosure(x)) {
234		# app developer might provide failing function
235	91x	idx_match <- unique(tidyselect::eval_select(expr = x, data))
236	91x	.possible_choices(data[idx_match])
237		},
238	431x	error = function(e) NULL # not returning error to avoid design complication to handle errors
239		)
240
241	431x	out <- out[!is.infinite(out)]
242	431x	out <- out[!is.na(out)]
243
244	431x	if (length(out) == 0) {
245	5x	warning(
246	5x	"None of the `choices/selected`: ", rlang::as_label(x), "\n",
247	5x	"are subset of: ", toString(.possible_choices(data), width = 30), "\n",
248	5x	"Emptying choices..."
249		)
250	5x	return(NULL)
251		}
252		# unique() for idx containing duplicated values
253	426x	if (is.atomic(out) && length(out)) out # this function should return atomic vector of length > 1 or NULL
254		}
255
256		#' @rdname dot-determine_choices
257		.possible_choices <- function(data) {
258	433x	if (is.factor(data)) {
259	6x	levels(data)
260	427x	} else if (is.atomic(data)) {
261	48x	unique(data)
262		} else {
263	379x	names(data)
264		}
265		}
266
267		.extract <- function(x, data) {
268	226x	if (length(x$selected) == 0) {
269	3x	NULL # this nullifies following pick-elements. See determine (generic)
270	223x	} else if (length(x$selected) == 1 && inherits(x, "datasets")) {
271	137x	data[[x$selected]]
272	86x	} else if (all(x$selected %in% names(data))) {
273	86x	data[x$selected]
274		}
275		}
276
277		.nullify_pick <- function(x) {
278	5x	x$choices <- NULL
279	5x	x$selected <- NULL
280	5x	x
281		}
282
283		.range_without_warnings <- function(..., pattern = "no non-missing arguments to (min\|max)") {
284	!	withCallingHandlers(
285	!	range(...),
286	!	warning = function(w) {
287	!	if (grepl(pattern, conditionMessage(w))) invokeRestart("muffleWarning")
288		}
289		)
290		}

1		#' Checks `varname` argument and convert to call
2		#'
3		#' Checks `varname` type and parse if it's a `character`.
4		#'
5		#' @param varname (`name` or `call` or `character(1)`)
6		#' name of the variable
7		#'
8		#' @returns the parsed `varname`.
9		#'
10		#' @keywords internal
11		#'
12		call_check_parse_varname <- function(varname) {
13	10x	checkmate::assert(
14	10x	checkmate::check_string(varname),
15	10x	checkmate::check_class(varname, "call"),
16	10x	checkmate::check_class(varname, "name")
17		)
18	10x	if (is.character(varname)) {
19	9x	parsed <- parse(text = varname, keep.source = FALSE)
20	9x	if (length(parsed) == 1) {
21	9x	varname <- as.name(varname)
22		} else {
23	!	stop(
24	!	sprintf(
25	!	"Problem with parsing '%s'. Not able to process multiple calls",
26	!	varname
27		)
28		)
29		}
30		}
31	10x	varname
32		}
33
34		#' Choices condition call
35		#'
36		#' Compose choices condition call from inputs.
37		#'
38		#' @details
39		#' `choices` can be vector of any type but for some output might be converted:
40		#' * `factor` call is composed on choices converted to `character`;
41		#' * `Date` call is composed on choices converted to `character` using
42		#' `format(choices)`;
43		#' * `POSIXct`, `POSIXlt` call is composed on choices converted to `character` using
44		#' `format(choices)`.
45		#'
46		#' One has to be careful here as formatted date-time variable might loose
47		#' some precision (see `format` argument in [format.POSIXlt()] and output call
48		#' could be insufficient for exact comparison. In this case one should specify
49		#' `varname = trunc(<varname>)` and possibly convert `choices` to `character`).
50		#'
51		#' @param varname (`name` or `call` or `character(1)`)
52		#' name of the variable.
53		#' @param choices (`vector`)
54		#' `varname` values to match using the `==` (single value) or `%in%` (vector)
55		#' condition.
56		#'
57		#' @return `call`.
58		#'
59		#' @keywords internal
60		#'
61		call_condition_choice <- function(varname, choices) {
62	6x	varname <- call_check_parse_varname(varname)
63
64	6x	if (is.factor(choices)) {
65	!	choices <- as.character(choices)
66	6x	} else if (inherits(choices, "Date")) {
67	1x	choices <- format(choices)
68	5x	} else if (inherits(choices, c("POSIXct", "POSIXlt"))) {
69	1x	choices <- format(choices)
70		}
71
72
73	6x	if (length(choices) == 1) {
74	2x	call("==", varname, unname(choices))
75		} else {
76	4x	c_call <- do.call(
77	4x	"call",
78	4x	append(list("c"), unname(choices))
79		)
80		# c_call needed because it needs to be vector call
81		# instead of vector. SummarizedExperiment.subset
82		# handles only vector calls
83	4x	call("%in%", as.name(varname), c_call)
84		}
85		}
86
87		#' `numeric` range condition call
88		#'
89		#' Compose `numeric` range condition call from inputs.
90		#'
91		#' @param varname (`name` or `character(1)`)
92		#' name of the variable.
93		#'
94		#' @param range (`numeric(2)`)
95		#' range of the variable.
96		#'
97		#' @return `call`.
98		#'
99		#' @keywords internal
100		#'
101		call_condition_range <- function(varname, range) {
102	1x	checkmate::assert_numeric(range, len = 2, sorted = TRUE)
103
104	1x	varname <- call_check_parse_varname(varname)
105	1x	call(
106		"&",
107	1x	call(">=", varname, unname(range[1])),
108	1x	call("<=", varname, unname(range[2]))
109		)
110		}
111
112		#' `logical` variable condition call
113		#'
114		#' Compose `logical` variable condition call from inputs.
115		#'
116		#' @param varname (`name` or `character(1)`)
117		#' name of the variable
118		#'
119		#' @param choice (`logical(1)`)
120		#' chosen value
121		#'
122		#' @return `call`.
123		#'
124		#' @keywords internal
125		#'
126		call_condition_logical <- function(varname, choice) {
127	1x	checkmate::assert_flag(choice)
128	1x	varname <- call_check_parse_varname(varname)
129
130	1x	if (choice) {
131	1x	varname
132	!	} else if (!choice) {
133	!	call("!", varname)
134		} else {
135	!	stop(
136	!	"Unknown filter state", toString(choice),
137	!	" for logical var ", as.character(varname)
138		)
139		}
140		}
141
142		#' `POSIXct` range condition call
143		#'
144		#' Compose `POSIXct` range condition call from inputs.
145		#'
146		#' @param varname (`name` or `character(1)`) name of the variable.
147		#' @param range (`POSIXct`) range of the variable.
148		#' Be aware that output uses truncated range format `"%Y-%m-%d %H:%M:%S"`,
149		#' which means that some precision might be lost.
150		#' @param timezone (`character(1)`) specifies the time zone to be used for the conversion.
151		#' By default `Sys.timezone()` is used.
152		#'
153		#' @return `call`.
154		#'
155		#' @keywords internal
156		#'
157		call_condition_range_posixct <- function(varname, range, timezone = Sys.timezone()) {
158	1x	checkmate::assert_posixct(range, len = 2, sorted = TRUE)
159	1x	checkmate::assert_string(timezone)
160	1x	varname <- call_check_parse_varname(varname)
161
162	1x	range[1] <- trunc(range[1], units = c("secs"))
163	1x	range[2] <- trunc(range[2] + 1, units = c("secs"))
164
165	1x	range <- format.POSIXct(
166	1x	unname(range),
167	1x	format = "%Y-%m-%d %H:%M:%S",
168	1x	tz = timezone
169		)
170
171	1x	call(
172		"&",
173	1x	call(">=", varname, call("as.POSIXct", range[1], tz = timezone)),
174	1x	call("<", varname, call("as.POSIXct", range[2], tz = timezone))
175		)
176		}
177
178		#' `Date` range condition call
179		#'
180		#' Compose `Date` range condition call from inputs.
181		#'
182		#' @param varname (`name` or `character(1)`) name of the variable.
183		#' @param range (`Date`) range of the variable.
184		#'
185		#' @return `call`.
186		#'
187		#' @keywords internal
188		#'
189		call_condition_range_date <- function(varname, range) {
190	1x	checkmate::assert_date(range, len = 2)
191	1x	checkmate::assert_true(range[2] >= range[1])
192	1x	varname <- call_check_parse_varname(varname)
193
194	1x	call(
195		"&",
196	1x	call(">=", varname, call("as.Date", as.character(range[1]))),
197	1x	call("<=", varname, call("as.Date", as.character(range[2])))
198		)
199		}
200
201		#' Combine calls by operator
202		#'
203		#' Combine list of calls by specific operator.
204		#'
205		#' @param operator (`character(1)` or `name`) name / symbol of the operator.
206		#' @param calls (`list` of calls) list containing calls to be combined by `operator`.
207		#'
208		#' @return A combined `call`.
209		#'
210		#' @keywords internal
211		#'
212		calls_combine_by <- function(operator, calls) {
213	36x	checkmate::assert_string(operator)
214	36x	stopifnot(
215	36x	all(
216	36x	vapply(
217	36x	X = calls,
218	36x	FUN.VALUE = logical(1),
219	36x	FUN = function(x) is.language(x) \|\| is.logical(x)
220		)
221		)
222		)
223	36x	Reduce(
224	36x	x = calls,
225	36x	f = function(x, y) call(operator, x, y)
226		)
227		}
228
229		#' `dplyr::select` call
230		#'
231		#' Create `dplyr::select` call from `dataname` and `variables`
232		#' @param dataname (`character(1)`) name of the dataset
233		#' @param variables (`list` of `character`) variables to select. If list is named then
234		#' variables will be renamed if their name is different than its value
235		#' (this produces a call `select(..., <name> = <value>)`).
236		#' @return `call`.
237		#' @keywords internal
238		.call_dplyr_select <- function(dataname, variables) {
239	37x	as.call(
240	37x	c(
241	37x	list(
242	37x	str2lang("dplyr::select"),
243	37x	str2lang(dataname)
244		),
245	37x	lapply(unname(variables), as.name)
246		)
247		)
248		}
249
250		#' `dplyr::filter` call
251		#'
252		#' Create a `dplyr::filter` call
253		#' @param x (`list`) containing `variables` and `values`
254		#' @return `call`.
255		#' @keywords internal
256		.call_dplyr_filter <- function(x) {
257	11x	if (any(!names(x) %in% c("variables", "values"))) {
258	11x	predicates <- lapply(unname(x), .predicates)
259	11x	predicates <- Filter(length, predicates)
260		} else {
261	!	predicates <- .predicates(x)
262		}
263
264	11x	as.call(c(list(str2lang("dplyr::filter")), predicates))
265		}
266
267		.predicates <- function(x) {
268	11x	if (is.numeric(x$values) && .is_ranged(x$values)) {
269	1x	call_condition_range(varname = x$variables, range = x$values)
270	10x	} else if (inherits(x$values, "Date") && .is_ranged(x$values)) {
271	1x	call_condition_range_date(varname = x$variables, range = x$values)
272	9x	} else if (inherits(x$values, "POSIXct") && .is_ranged(x$values)) {
273	1x	call_condition_range_posixct(varname = x$variables, range = x$values)
274	8x	} else if (is.logical(x$values)) {
275	1x	call_condition_logical(varname = x$variables, choice = x$values)
276		} else if (
277	7x	checkmate::test_list(x$operators, types = "operator", min.len = 1) &&
278	7x	.is_operator_selected(x$operators, x$variables)
279		) {
280	1x	if (length(x$operators) > 1) {
281	!	showNotification("Only a single complex operator can be used at a time when filtering by values.", type = "error")
282	!	return(NULL)
283		}
284	1x	if (length(x$variables) > 1) {
285	!	showNotification(
286	!	"A complex operator filter cannot be combined with other variables. Filtering by the first variable only.",
287	!	type = "error"
288		)
289	!	return(NULL)
290		}
291	1x	.call_condition_operators(x$operators[[1]], choices = x$values)
292	6x	} else if (length(x$variables)) {
293	6x	if (is.factor(x$values)) {
294	!	x$values <- as.numeric(levels(x$values))[x$values]
295		}
296
297	6x	variable <- if (length(x$variables) > 1) {
298	1x	as.call(
299	1x	list(
300	1x	quote(apply),
301	1x	as.call(
302	1x	c(
303	1x	list(quote(data.frame)),
304	1x	unname(lapply(x$variables, as.name))
305		)
306		),
307	1x	1,
308	1x	quote(toString)
309		)
310		)
311		} else {
312	5x	x$variables
313		}
314	6x	call_condition_choice(varname = variable, choices = x$values)
315		}
316		}
317
318		.call_mutate_operators <- function(variables, operators_ix, dataname, operators) {
319	1x	operators <- rlang::set_names(operators, vapply(operators, attr, which = "var_name", FUN.VALUE = character(1)))
320	1x	select_new <- variables[operators_ix]
321	1x	select_tmp <- unname(unlist(operators[select_new]))
322	1x	select_call <- .call_dplyr_select(
323	1x	dataname = dataname,
324	1x	variables = unique(c(variables[!operators_ix], select_tmp))
325		)
326
327	1x	select_call
328		}

1		#' Interactive picks
2		#'
3		#' @description
4		#'
5		#' Creates UI and server components for interactive [picks()] in Shiny modules. The module is based on
6		#' configuration provided via [picks()] and its responsibility is to determine relevant input
7		#' values
8		#'
9		#'
10		#' The module supports both single and combined `picks`:
11		#' - Single `picks` objects for a single input
12		#' - Named lists of `picks` objects for multiple inputs
13		#'
14		#' @param id (`character(1)`) Shiny module ID
15		#' @param picks (`picks` or `list`) object created by `picks()` or a named list of such objects
16		#' @param container (`character(1)` or `function`) UI container type. Can be one of `htmltools::tags`
17		#' functions. By default, elements are wrapped in a package-specific drop-down.
18		#' @param data (`reactive`) Reactive expression returning the data object to be used for populating choices
19		#'
20		#' @return
21		#' - `picks_ui()`: UI elements for the input controls
22		#' - `picks_srv()`: Server-side reactive logic returning the processed data
23		#'
24		#' @details
25		#' The module uses S3 method dispatch to handle different ways to provide `picks`:
26		#' - `.picks` methods handle single `picks`` object
27		#' - `.list` methods handle multiple `picks` objects
28		#'
29		#' The UI component (`picks_ui`) creates the visual elements, while the
30		#' server component (`picks_srv`) manages the reactive logic,
31		#'
32		#' @seealso [picks()] for creating `picks`` objects
33		#'
34		#' @name picks_module
35		#' @examples
36		#' library(shiny)
37		#'
38		#' example_pick <- picks(
39		#' datasets("ADSL"),
40		#' variables(selected = c("SEX", "COUNTRY", "ARMCD"))
41		#' )
42		#' ui <- fluidPage(
43		#' picks_ui("my_picks", picks = example_pick),
44		#' h4("Resolved picks:"),
45		#' verbatimTextOutput("result"),
46		#' h4("Table:"),
47		#' tableOutput("table")
48		#' )
49		#' server <- function(input, output, session) {
50		#' data <- teal.data::teal_data("ADSL" = teal.data::rADSL)
51		#' teal.data::join_keys(data) <- teal.data::default_cdisc_join_keys["ADSL"]
52		#' selectors <- picks_srv(
53		#' picks = list(my_picks = example_pick),
54		#' data = reactive(data)
55		#' )
56		#' anl <- merge_srv("merge", data = reactive(data), selectors = selectors)
57		#' output$result <- renderPrint(cat(gsub("\033\\[[0-9;]*m", "", format(selectors$my_picks()))))
58		#' output$table <- renderTable(anl$data()$anl)
59		#' }
60		#'
61		#' if (interactive()) {
62		#' shinyApp(ui, server)
63		#' }
64		NULL
65
66		#' @rdname picks_module
67		#' @export
68		picks_ui <- function(id, picks, container = "badge_dropdown") {
69	14x	checkmate::assert_string(id)
70	14x	UseMethod("picks_ui", picks)
71		}
72
73		#' @rdname picks_module
74		#' @export
75		picks_ui.list <- function(id, picks, container) {
76	!	checkmate::assert_list(picks, names = "unique")
77	!	ns <- shiny::NS(id)
78	!	sapply(
79	!	Filter(length, names(picks)),
80	!	USE.NAMES = TRUE,
81	!	function(name) picks_ui(ns(name), picks[[name]], container = container)
82		)
83		}
84
85		#' @rdname picks_module
86		#' @export
87		picks_ui.picks <- function(id, picks, container) {
88	14x	ns <- shiny::NS(id)
89	14x	badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span)
90	14x	content <- lapply(picks, function(x) .pick_ui(id = ns(methods::is(x))))
91	14x	if (missing(container)) {
92	13x	htmltools::tags$div(
93	13x	if (all(vapply(picks, is_pick_fixed, logical(1)))) {
94	10x	badge_fixed(id = ns("inputs"), badge_label, htmltools::tagList(content))
95		} else {
96	3x	badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content))
97		}
98		)
99		} else {
100	1x	if (!any(sapply(htmltools::tags, identical, container))) {
101	!	stop("Container should be one of `htmltools::tags`")
102		}
103	1x	htmltools::tags$div(container(content))
104		}
105		}
106
107		#' @rdname picks_module
108		#' @export
109		picks_srv <- function(id = "", picks, data) {
110	83x	checkmate::assert_string(id)
111	83x	checkmate::assert_class(data, "reactive")
112	80x	UseMethod("picks_srv", picks)
113		}
114
115		#' @rdname picks_module
116		#' @export
117		picks_srv.list <- function(id, picks, data) {
118	17x	checkmate::assert_named(picks, type = "unique")
119	15x	sapply(
120	15x	names(Filter(length, picks)),
121	15x	USE.NAMES = TRUE,
122	15x	function(name) picks_srv(name, picks[[name]], data)
123		)
124		}
125
126		#' @rdname picks_module
127		#' @export
128		picks_srv.picks <- function(id, picks, data) {
129	61x	shiny::moduleServer(id, function(input, output, session) {
130	61x	picks_resolved <- shiny::reactiveVal(
131	61x	restoreValue(
132	61x	session$ns("picks"),
133	61x	resolver(picks, shiny::isolate(data()))
134		)
135		)
136
137	58x	session$onBookmark(function(state) {
138	!	logger::log_debug("picks_srv@onBookmark: storing current picks")
139	!	state$values$picks <- picks_resolved()
140		})
141
142	58x	exportTestValues(
143	58x	open_id_fmt = session$ns("%s-selected_open"),
144	58x	selected_id_fmt = session$ns("%s-selected"),
145	58x	range_id_fmt = session$ns("%s-range"),
146	58x	picks_resolved = picks_resolved()
147		)
148
149	58x	badge <- shiny::reactive({
150	43x	lapply(
151	43x	picks_resolved(),
152	43x	function(x) {
153	76x	label <- if (inherits(x, "values")) {
154	6x	if (!setequal(x$choices, x$selected)) {
155	4x	bsicons::bs_icon("funnel")
156		}
157	76x	} else if (length(x$selected)) {
158	68x	toString(x$selected)
159		} else {
160		"~"
161		}
162	76x	label
163		}
164		)
165		})
166
167	58x	output$summary <- shiny::renderUI({
168	43x	badge_value <- badge()
169	43x	hover_text <- paste(
170	43x	vapply(
171	43x	names(badge_value)[names(badge_value) %in% c("datasets", "variables")],
172	43x	function(x) sprintf("%s: %s", x, paste(badge_value[[x]], collapse = ", ")),
173	43x	FUN.VALUE = character(1)
174		),
175	43x	collapse = "\n"
176		)
177	43x	htmltools::tags$span(title = hover_text, tagList(badge_value))
178		})
179
180	58x	Reduce(
181	58x	function(this_data, slot_name) { # this_data is a (drilled-down) data for current pick
182	112x	choices <- reactiveVal(isolate(picks_resolved())[[slot_name]]$choices)
183	112x	selected <- reactiveVal(isolate(picks_resolved())[[slot_name]]$selected)
184	112x	all_choices <- shiny::reactive(determine(x = picks[[slot_name]], data = this_data())$x$choices)
185
186	112x	observeEvent(all_choices(), ignoreInit = TRUE, {
187	13x	current_selected <- picks_resolved()[[slot_name]]$selected
188	13x	new_selected <- if (is.numeric(current_selected) && is.numeric(all_choices())) {
189	1x	c(
190	1x	max(current_selected[1], all_choices()[1], na.rm = TRUE),
191	1x	min(current_selected[2], all_choices()[2], na.rm = TRUE)
192		)
193		} else {
194	12x	intersect(current_selected, all_choices())
195		}
196
197	13x	.update_rv(
198	13x	selected, new_selected,
199	13x	sprintf("picks_srv@1 %s$%s$selected is outside of the possible choices", id, slot_name)
200		)
201	13x	.update_rv(
202	13x	choices, all_choices(),
203	13x	sprintf("picks_srv@1 %s$%s$choices is outside of the possible choices", id, slot_name)
204		)
205		})
206
207	112x	observeEvent(picks_resolved()[[slot_name]], ignoreInit = TRUE, ignoreNULL = FALSE, {
208	21x	.update_rv(choices, picks_resolved()[[slot_name]]$choices, log = "picks_srv@1 update input choices")
209	21x	.update_rv(selected, picks_resolved()[[slot_name]]$selected, log = "picks_srv@1 update input selected")
210		})
211
212	112x	args <- attributes(picks[[slot_name]])
213	112x	args <- args[!names(args) %in% c("names", "class")]
214
215	112x	.pick_srv(
216	112x	id = slot_name,
217	112x	pick_type = slot_name,
218	112x	choices = choices,
219	112x	selected = selected,
220	112x	args = args[!names(args) %in% c("names", "class")],
221	112x	data = this_data
222		)
223
224		# this works as follows:
225		# Each observer is observes input$selected of i-th element of picks ($datasets, $variables, ...)
226	112x	shiny::observeEvent(
227	112x	selected(),
228	112x	ignoreInit = TRUE, # because picks_resolved is already resolved and `selected()` is being set
229	112x	ignoreNULL = FALSE, # because input$selected can be empty
230		{
231	16x	.resolve(
232	16x	selected(),
233	16x	slot_name = slot_name,
234	16x	picks_resolved = picks_resolved,
235	16x	old_picks = picks,
236	16x	data = data() # data() object needed as we resolve the WHOLE picks INSTEAD OF one picks element.
237		)
238		}
239		)
240
241	112x	shiny::reactive(.extract(x = picks_resolved()[[slot_name]], this_data()))
242		},
243	58x	x = names(picks),
244	58x	init = data
245		)
246
247	58x	picks_resolved
248		})
249		}
250
251		.pick_ui <- function(id) {
252	29x	ns <- shiny::NS(id)
253	29x	uiOutput(ns("selected_container"))
254		}
255
256		.pick_srv <- function(id, pick_type, choices, selected, data, args) {
257	112x	checkmate::assert_string(id)
258	112x	checkmate::assert_class(choices, "reactiveVal")
259	112x	checkmate::assert_class(selected, "reactiveVal")
260	112x	checkmate::assert_list(args)
261
262	112x	shiny::moduleServer(id, function(input, output, session) {
263	112x	choices_opt_content <- shiny::reactive({
264	38x	if (pick_type != "values") {
265	36x	sapply(
266	36x	choices(),
267	36x	function(choice) {
268	121x	icon <- toString(icon(.picker_icon(data()[[choice]]), lib = "font-awesome"))
269	121x	label <- attr(data()[[choice]], "label")
270	121x	paste(
271	121x	icon,
272	121x	choice,
273	121x	if (!is.null(label) && !is.na(label) && !identical(label, choice)) {
274	4x	toString(tags$small(label, class = "text-muted"))
275		}
276		)
277		}
278		)
279		}
280		})
281
282	112x	output$selected_container <- renderUI({
283	61x	logger::log_debug(".pick_srv@1 rerender {pick_type} input")
284	61x	.validate_is_eager(choices())
285	61x	.validate_is_eager(selected())
286	61x	if (!length(choices()) \|\| isTRUE(args$fixed)) {
287	19x	.pick_ui_fixed(session$ns("selected"), selected())
288	42x	} else if (.is_ranged(choices()) && inherits(choices(), "Date")) {
289	1x	.pick_ui_date(
290	1x	session$ns("range"),
291	1x	label = sprintf("Select %s range:", pick_type),
292	1x	choices = choices(),
293	1x	selected = selected(),
294	1x	args = args
295		)
296	41x	} else if (.is_ranged(choices()) && inherits(choices(), "POSIXct")) {
297	1x	.pick_ui_posixct(
298	1x	session$ns("range"),
299	1x	label = sprintf("Select %s range:", pick_type),
300	1x	choices = choices(),
301	1x	selected = selected(),
302	1x	args = args
303		)
304	40x	} else if (.is_ranged(choices())) {
305	1x	.pick_ui_numeric(
306	1x	session$ns("range"),
307	1x	label = sprintf("Select %s range:", pick_type),
308	1x	choices = choices(),
309	1x	selected = selected(),
310	1x	args = args
311		)
312		} else {
313	39x	.pick_ui_categorical(
314	39x	session$ns("selected"),
315	39x	label = sprintf("Select %s:", pick_type),
316	39x	choices = choices(),
317	39x	selected = selected(),
318	39x	multiple = args$multiple,
319	39x	choicesOpt = list(content = isolate(choices_opt_content())),
320	39x	args = args[!names(args) %in% c("multiple")]
321		)
322		}
323	112x	}) \|> bindEvent(choices(), ignoreNULL = FALSE) # never change on selected()
324
325		# for numeric / date / posixct range
326	112x	range_debounced <- shiny::reactive(input$range) \|> debounce(1000)
327	112x	shiny::observeEvent(range_debounced(), {
328	!	new_value <- input$range
329	!	if (inherits(choices(), "POSIXct")) {
330	!	new_value <- as.POSIXct(new_value)
331		}
332	!	.update_rv(
333	!	selected,
334	!	.as_ranged(new_value),
335	!	log = ".pick_srv@2 update selected after input changed"
336		)
337		})
338
339
340		# for non-numeric
341	112x	shiny::observeEvent(input$selected_open, {
342		# Update when closes and the input is different from what it was selected
343	11x	if (!isTRUE(input$selected_open) && !isTRUE(all.equal(input$selected, sort(selected())))) {
344		# ↓ pickerInput returns "" when nothing selected. This can cause failure during col select (x[,""])
345	9x	new_selected <- if (length(input$selected) && !identical(input$selected, "")) as.vector(input$selected)
346	9x	if (args$ordered) {
347	3x	new_selected <- c(intersect(selected(), new_selected), setdiff(new_selected, selected()))
348		}
349	9x	.update_rv(selected, new_selected, log = ".pick_srv@1 update selected after input changed")
350		}
351		})
352	112x	selected
353		})
354		}
355
356		.pick_ui_fixed <- function(id, selected) {
357	19x	htmltools::tags$div(
358	19x	class = "form-group shiny-input-container",
359	19x	style = "visibility: hidden; position: absolute;",
360	19x	htmltools::tags$input(
361	19x	id = id,
362	19x	disabled = "disabled",
363	19x	value = selected
364		)
365		)
366		}
367
368		.pick_ui_date <- function(id, label, choices, selected, args) {
369	1x	shiny::dateRangeInput(
370	1x	inputId = id,
371	1x	label = label,
372	1x	min = choices[1],
373	1x	max = utils::tail(choices, 1),
374	1x	start = selected[1],
375	1x	end = utils::tail(selected, 1)
376		)
377		}
378
379		.pick_ui_posixct <- function(id, label, choices, selected, args) {
380	1x	shiny::dateRangeInput(
381	1x	inputId = id,
382	1x	label = label,
383	1x	min = as.Date(choices[1]),
384	1x	max = as.Date(utils::tail(choices, 1)),
385	1x	start = as.Date(selected[1]),
386	1x	end = as.Date(utils::tail(selected, 1))
387		)
388		}
389
390		.pick_ui_numeric <- function(id, label, choices, selected, args) {
391	1x	shinyWidgets::numericRangeInput(
392	1x	inputId = id,
393	1x	label = label,
394	1x	min = unname(choices[1]),
395	1x	max = unname(utils::tail(choices, 1)),
396	1x	value = unname(selected)
397		)
398		}
399
400		.pick_ui_categorical <- function(id, label, choices, selected, multiple, choicesOpt, args) { # nolint
401	39x	htmltools::div(
402	39x	style = "max-width: 500px;",
403	39x	shinyWidgets::pickerInput(
404	39x	inputId = id,
405	39x	label = label,
406	39x	choices = choices,
407	39x	selected = selected,
408	39x	multiple = multiple,
409	39x	choicesOpt = choicesOpt,
410	39x	options = c(
411	39x	list(
412	39x	"actions-box" = !multiple,
413	39x	"live-search" = length(choices) > 10,
414	39x	"none-selected-text" = "- Nothing selected -",
415	39x	"show-subtext" = TRUE
416		),
417	39x	args
418		)
419		)
420		)
421		}
422
423		#' Update reactive values with log
424		#'
425		#' Update reactive values only if values differ to avoid unnecessary reactive trigger
426		#' @param rv (`reactiveVal`)
427		#' @param value (`vector`)
428		#' @param log (`character(1)`) message to `log_debug`
429		#' @return the result of `reactiveVal` update if new value is different, `NULL` otherwise.
430		#' @keywords internal
431		.update_rv <- function(rv, value, log) {
432	77x	if (!isTRUE(all.equal(rv(), value, tolerance = 1e-15))) { # tolerance 1e-15 is a max precision in widgets.
433	23x	logger::log_debug(log)
434	23x	rv(value)
435		}
436		}
437
438		#' Resolve downstream after selected changes
439		#'
440		#' @description
441		#' When select input at position `i` changes:
442		#' - All slots after position i in `picks_resolved` are reset to their unresolved (delayed) state,
443		#' because later slots depend on earlier ones. Slots before and at position i are kept as-is.
444		#' For example, changing variables (i=2) resets everything after it but keeps dataset (i=1) intact.
445		#' - The new selection replaces the old value at slot i.
446		#' - Resolve is called, which evaluates only the slots that are still in an unresolved state.
447		#' - The updated picks replace the current `reactiveValue`.
448		#' Thanks to this design reactive values are triggered only once
449		#' @param selected (`vector`) rather `character`, or `factor`. `numeric(2)` for `values()` based on numeric column.
450		#' @param slot_name (`character(1)`) one of `c("datasets", "variables", "values")`
451		#' @param picks_resolved (`reactiveVal`)
452		#' @param old_picks (`picks`)
453		#' @param data (`any` asserted further in `resolver`)
454		#' @return The result of changing the `picks_resolved` `reactiveVal` given as argument.
455		#' It returns `NULL` if it does nothing.
456		#' @keywords internal
457		.resolve <- function(selected, slot_name, picks_resolved, old_picks, data) {
458	16x	checkmate::assert_vector(selected, null.ok = TRUE)
459	16x	checkmate::assert_string(slot_name)
460	16x	checkmate::assert_class(picks_resolved, "reactiveVal")
461	16x	checkmate::assert_class(old_picks, "picks")
462		# Input and new selection is the same
463	16x	if (isTRUE(all.equal(unclass(selected), unclass(picks_resolved()[[slot_name]]$selected), tolerance = 1e-15))) {
464	6x	return(NULL)
465		}
466	10x	logger::log_info("picks_server@1 selected has changed. Resolving downstream...")
467
468	10x	new_picks_unresolved <- old_picks
469		# ↓ everything after `slot_idx` is to resolve
470	10x	slot_idx <- which(names(old_picks) == slot_name)
471	10x	new_picks_unresolved[seq_len(slot_idx - 1)] <- picks_resolved()[seq_len(slot_idx - 1)]
472
473	10x	if (.is_ranged(selected)) {
474	!	selected <- ranged(selected[1], selected[2])
475		}
476	10x	new_picks_unresolved[[slot_idx]]$selected <- selected
477
478	10x	resolver_warnings <- character(0)
479	10x	new_picks_resolved <- withCallingHandlers(
480	10x	resolver(new_picks_unresolved, data),
481	10x	warning = function(w) {
482	1x	resolver_warnings <<- paste(conditionMessage(w), collapse = " ")
483		}
484		)
485	10x	if (length(resolver_warnings)) {
486	1x	showNotification(resolver_warnings, type = "error")
487		}
488
489	10x	picks_resolved(new_picks_resolved)
490		}
491
492		#' Restore value from bookmark.
493		#'
494		#' Get value from bookmark or return default.
495		#'
496		#' Bookmarks can store not only inputs but also arbitrary values.
497		#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks,
498		#' and they are placed in the `values` environment in the `session$restoreContext` field.
499		#' Using `teal_data_module` makes it impossible to run the callbacks
500		#' because the app becomes ready before modules execute and callbacks are registered.
501		#' In those cases the stored values can still be recovered from the `session` object directly.
502		#'
503		#' Note that variable names in the `values` environment are prefixed with module name space names,
504		#' therefore, when using this function in modules, `value` must be run through the name space function.
505		#'
506		#' @param value (`character(1)`) name of value to restore
507		#' @param default fallback value
508		#'
509		#' @return
510		#' In an application restored from a server-side bookmark,
511		#' the variable specified by `value` from the `values` environment.
512		#' Otherwise `default`.
513		#'
514		#' @keywords internal
515		restoreValue <- function(value, default) { # nolint: object_name.
516	61x	checkmate::assert_character("value")
517	61x	session_default <- shiny::getDefaultReactiveDomain()
518	61x	session_parent <- .subset2(session_default, "parent")
519	61x	session <- if (is.null(session_parent)) session_default else session_parent
520
521	61x	if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
522	!	session$restoreContext$values[[value]]
523		} else {
524	61x	default
525		}
526		}
527
528		#' `pickerInput` choices icons
529		#'
530		#' Icons describing a class of the choice
531		#' @param x (`any`) object which class will determine icon
532		#' @return html-tag in form of `character(1)`
533		#' @keywords internal
534		.picker_icon <- function(x) {
535	121x	UseMethod(".picker_icon")
536		}
537
538		#' @keywords internal
539		#' @export
540	61x	.picker_icon.numeric <- function(x) "arrow-up-1-9"
541
542		#' @keywords internal
543		#' @export
544	4x	.picker_icon.integer <- function(x) "arrow-up-1-9"
545
546		#' @keywords internal
547		#' @export
548	1x	.picker_icon.logical <- function(x) "pause"
549
550		#' @keywords internal
551		#' @export
552	2x	.picker_icon.Date <- function(x) "calendar"
553
554		#' @keywords internal
555		#' @export
556	2x	.picker_icon.POSIXct <- function(x) "calendar"
557
558		#' @keywords internal
559		#' @export
560	!	.picker_icon.POSIXlt <- function(x) "calendar"
561
562		#' @keywords internal
563		#' @export
564	12x	.picker_icon.factor <- function(x) "chart-bar"
565
566		#' @keywords internal
567		#' @export
568	1x	.picker_icon.character <- function(x) "font"
569
570		#' @keywords internal
571		#' @export
572	!	.picker_icon.primary_key <- function(x) "key"
573
574		#' @keywords internal
575		#' @export
576	38x	.picker_icon.data.frame <- function(x) "table"
577
578		#' @keywords internal
579		#' @export
580	!	.picker_icon.default <- function(x) "circle-question"

1		#' Convert data_extract_spec to picks
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#' Helper functions to ease transition between [teal.transform::data_extract_spec()] and [picks()].
6		#' @inheritParams teal::teal_transform_module
7		#' @param x (`data_extract_spec`, `select_spec`, `filter_spec`) object to convert to [`picks`]
8		#' @param quiet (`logical(1)`) whether to suppress warnings about non-convertible elements.
9		#' @details
10		#' With introduction of [`picks`], [`data_extract_spec`] will no longer serve a primary tool to
11		#' define variable choices and default selection in teal-modules and eventually [`data_extract_spec`]
12		#' will be deprecated.
13		#' To ease the transition to the new tool, we provide `as.picks` method which can handle 1:1
14		#' conversion from [`data_extract_spec`] to [`picks`]. Unfortunately, when [`data_extract_spec`]
15		#' contains [`filter_spec`] then `as.picks` is unable to provide reliable [`picks`] equivalent.
16		#'
17		#' @return A `picks` object when conversion is possible, otherwise `NULL` with a warning (if `quiet = FALSE`).
18		#' @examples
19		#' # convert des with eager select_spec
20		#' as.picks(
21		#' teal.transform::data_extract_spec(
22		#' dataname = "iris",
23		#' teal.transform::select_spec(
24		#' choices = c("Sepal.Length", "Sepal.Width", "Species"),
25		#' selected = c("Sepal.Length", "Species"),
26		#' multiple = TRUE,
27		#' ordered = TRUE
28		#' )
29		#' )
30		#' )
31		#'
32		#' # convert des with delayed select_spec
33		#' as.picks(
34		#' teal.transform::data_extract_spec(
35		#' dataname = "iris",
36		#' teal.transform::select_spec(
37		#' choices = teal.transform::variable_choices("iris"),
38		#' selected = teal.transform::first_choice(),
39		#' multiple = TRUE,
40		#' ordered = TRUE
41		#' )
42		#' )
43		#' )
44		#'
45		#' as.picks(
46		#' teal.transform::data_extract_spec(
47		#' dataname = "iris",
48		#' teal.transform::select_spec(
49		#' choices = teal.transform::variable_choices(
50		#' "iris",
51		#' subset = function(data) names(Filter(is.numeric, data))
52		#' ),
53		#' selected = teal.transform::first_choice(),
54		#' multiple = TRUE,
55		#' ordered = TRUE
56		#' )
57		#' )
58		#' )
59		#'
60		#' @export
61		as.picks <- function(x, quiet = FALSE) { # nolint: object_name_linter.
62	26x	checkmate::assert_flag(quiet)
63	26x	if (inherits(x, c("picks", "pick"))) {
64	!	x
65	26x	} else if (checkmate::test_list(x, c("data_extract_spec", "filter_spec"))) {
66	3x	Filter(length, lapply(x, as.picks, quiet = quiet))
67	23x	} else if (inherits(x, "data_extract_spec")) {
68	4x	args <- Filter(
69	4x	length,
70	4x	list(
71	4x	datasets(choices = x$dataname, fixed = TRUE),
72	4x	as.picks(x$select, quiet = quiet),
73	4x	as.picks(x$filter, quiet = quiet)
74		)
75		)
76	4x	do.call(picks, args)
77	19x	} else if (inherits(x, "select_spec")) {
78	6x	.select_spec_to_variables(x)
79	13x	} else if (inherits(x, "choices_selected")) {
80	2x	.choices_selected_to_variables(x)
81	11x	} else if (inherits(x, "filter_spec") && !quiet) {
82		# filter_spec is necessary linked with `select` (selected variables)
83		# so in most of the cases it can't beconverted into variables/values
84		# because filter_spec can be specified on the variable(s) different than select_spec for example (pseudocode):
85		# select_spec "AVAL"
86		# filter_spec "PARAMCD"
87	1x	warning(
88	1x	"`filter_spec` are not convertible to picks - please use `transformers` argument",
89	1x	" and create `teal_transform_module` containing necessary filter. See `?teal_transform_filter`"
90		)
91
92	1x	NULL
93	10x	} else if (!is.null(x) && !quiet) {
94	1x	warning(sprintf("'%s' are not convertible to picks", class(x)[1]))
95	1x	NULL
96		} else {
97	9x	NULL
98		}
99		}
100
101		#' @rdname as.picks
102		#' @examples
103		#' # teal_transform_module build on teal.transform
104		#'
105		#' teal_transform_filter(
106		#' teal.transform::data_extract_spec(
107		#' dataname = "iris",
108		#' filter = teal.transform::filter_spec(
109		#' vars = "Species",
110		#' choices = c("setosa", "versicolor", "virginica"),
111		#' selected = c("setosa", "versicolor")
112		#' )
113		#' )
114		#' )
115		#'
116		#' teal_transform_filter(
117		#' picks(
118		#' datasets(choices = "iris", select = "iris"),
119		#' variables(choices = "Species", "Species"),
120		#' values(
121		#' choices = c("setosa", "versicolor", "virginica"),
122		#' selected = c("setosa", "versicolor")
123		#' )
124		#' )
125		#' )
126		#'
127		#' @export
128		teal_transform_filter <- function(x, label = "Filter") {
129	5x	checkmate::assert_multi_class(x, c("data_extract_spec", "picks"))
130	4x	if (inherits(x, "data_extract_spec")) {
131	2x	lapply(.as.picks.filter(x), teal_transform_filter, label = label)
132		} else {
133	2x	checkmate::assert_true("values" %in% names(x))
134	2x	teal::teal_transform_module(
135	2x	label = label,
136	2x	ui = function(id) {
137	1x	ns <- NS(id)
138	1x	picks_ui(ns("transformer"), picks = x, container = div)
139		},
140	2x	server = function(id, data) {
141	1x	shiny::moduleServer(id, function(input, output, session) {
142	1x	selector <- picks_srv("transformer", picks = x, data = data)
143	1x	shiny::reactive({
144	1x	shiny::req(data(), selector())
145	1x	filter_call <- .make_filter_call(
146	1x	datasets = selector()$datasets$selected,
147	1x	variables = selector()$variables$selected,
148	1x	values = selector()$values$selected
149		)
150	1x	teal.code::eval_code(data(), filter_call)
151		})
152		})
153		}
154		)
155		}
156		}
157
158		.as.picks.filter <- function(x, dataname) { # nolint: object_name_linter.
159	6x	if (inherits(x, "filter_spec")) {
160	2x	if (inherits(x$choices, "delayed_data")) {
161	1x	warning(
162	1x	"teal.transform::filter_spec(choices) doesn't support delayed_data when using with teal_transform_filter. ",
163	1x	"Setting to all possible choices..."
164		)
165	1x	x$choices <- function(x) TRUE
166		}
167	2x	if (inherits(x$selected, "delayed_data")) {
168	!	warning(
169	!	"teal.transform::filter_spec(selected) doesn't support delayed_data when using with teal_transform_filter. ",
170	!	"Setting to all possible choices..."
171		)
172	!	x$selected <- function(x) TRUE
173		}
174	2x	picks(
175	2x	datasets(choices = dataname, selected = dataname),
176	2x	variables(choices = x$vars_choices, selected = x$vars_selected, multiple = FALSE), # can't be multiple
177	2x	values(choices = x$choices, selected = x$selected, multiple = x$multiple)
178		)
179	4x	} else if (checkmate::test_list(x, "filter_spec")) {
180	2x	lapply(x, .as.picks.filter, dataname = dataname)
181	2x	} else if (inherits(x, "data_extract_spec")) {
182	2x	.as.picks.filter(x$filter, dataname = x$dataname)
183	!	} else if (checkmate::test_list(x, c("data_extract_spec", "list", "NULL"))) {
184	!	unlist(
185	!	lapply(Filter(length, x), .as.picks.filter),
186	!	recursive = FALSE
187		)
188		}
189		}
190
191		.make_filter_call <- function(datasets, variables, values) {
192	1x	checkmate::assert_character(datasets)
193	1x	checkmate::assert_character(variables)
194	1x	checkmate::assert_character(values)
195	1x	substitute(
196	1x	dataname <- dplyr::filter(dataname, varname %in% values), # nolint: object_usage_linter.
197	1x	list(
198	1x	dataname = as.name(datasets),
199	1x	varname = if (length(variables) == 1) {
200	1x	as.name(variables)
201		} else {
202	!	as.call(
203	!	c(
204	!	quote(paste),
205	!	lapply(variables, as.name),
206	!	list(sep = ", ")
207		)
208		)
209		},
210	1x	values = values
211		)
212		)
213		}
214
215		.select_spec_to_variables <- function(x) {
216	8x	if (length(x)) {
217	8x	args <- list(
218	8x	choices = if (inherits(x$choices, "delayed_data")) {
219	3x	out <- x$choices$subset
220	3x	if (is.null(out)) {
221	1x	function(x) TRUE # same effect as tidyselect::everything
222		} else {
223	2x	class(out) <- "des-delayed"
224	2x	out
225		}
226		} else {
227	5x	x$choices
228		},
229	8x	selected = if (inherits(x$selected, "delayed_choices")) {
230	!	out <- x$selected
231	!	class(out) <- "des-delayed"
232	!	out
233	8x	} else if (inherits(x$selected, "delayed_data")) {
234	3x	out <- x$selected$subset
235	3x	if (is.null(out)) {
236	1x	1L
237		} else {
238	2x	class(out) <- "des-delayed"
239	2x	out
240		}
241		} else {
242	5x	unname(x$selected)
243		},
244	8x	ordered = x$ordered,
245	8x	multiple = x$multiple,
246	8x	fixed = x$fixed
247		)
248	8x	if (is.null(args$ordered)) { # Must be logical or missing for variables() to set default value
249	2x	args <- args[names(args) != c("ordered")]
250		}
251	8x	do.call(variables, args)
252		}
253		}
254
255		.choices_selected_to_variables <- function(x) {
256	2x	x$choices <- as.character(x$choices)
257	1x	if (!is.null(x$selected)) x$selected <- as.character(x$selected)
258	2x	.select_spec_to_variables(x)
259		}

1		#' Helper functions to check pick attributes
2		#' @description
3		#' Helper functions for pick objects generated from
4		#' [datasets()], [variables()] or [values()]:
5		#' @name helper_functions_pick
6		#' @param x (`datasets`, `variables` or `values`) pick to check.
7		#' @return `TRUE` if the pick has the attribute set to `TRUE`,
8		#' `FALSE` otherwise.
9		#' @description
10		#' - `is_pick_multiple()` checks if a pick has the `multiple` attribute set to `TRUE`.
11		#' @examples
12		#' p <- picks(datasets("iris"), variables(), values())
13		#'
14		#' is_pick_multiple(p$variables)
15		#' @export
16		is_pick_multiple <- function(x) {
17	8x	checkmate::assert_class(x, classes = c("pick"))
18	7x	checkmate::assert_flag(attr(x, "multiple", exact = TRUE))
19	7x	isTRUE(attr(x, "multiple", exact = TRUE))
20		}
21
22		#' @rdname helper_functions_pick
23		#' @description
24		#' - `is_pick_fixed()` checks if a pick has the `fixed` attribute set to `TRUE`.
25		#' @examples
26		#'
27		#' is_pick_fixed(p$variables)
28		#' @export
29		is_pick_fixed <- function(x) {
30	37x	checkmate::assert_class(x, classes = c("pick"))
31	36x	checkmate::assert_flag(attr(x, "fixed", exact = TRUE))
32	36x	isTRUE(attr(x, "fixed", exact = TRUE))
33		}
34
35		#' @rdname helper_functions_pick
36		#' @description
37		#' - `is_pick_ordered()` checks if a pick has the `ordered` attribute set to `TRUE`.
38		#' @examples
39		#'
40		#' is_pick_ordered(p$variables)
41		#' @export
42		is_pick_ordered <- function(x) {
43	8x	checkmate::assert_class(x, classes = c("pick"))
44	7x	checkmate::assert_flag(attr(x, "ordered", exact = TRUE))
45	7x	isTRUE(attr(x, "ordered", exact = TRUE))
46		}

1		#' Assert level
2		#'
3		#' @param x `picks` object
4		#' @param class Class of the last element of picks
5		#' @inheritParams checkmate::makeAssertionFunction
6		#' @inheritParams checkmate::assert
7		#' @rdname assert_last_level
8		#' @returns For `check_last_level` a logical value or a string.
9		#' For `assert_last_level` invisibly the object checked or an error.
10		#' @export
11		#' @examples
12		#' x <- picks(datasets(), variables(), values())
13		#' assert_last_level(x, "values")
14		check_last_level <- function(x, class) {
15	5x	checkmate::assert_character(class, len = 1, any.missing = FALSE)
16	5x	check <- inherits(x, "picks") && inherits(x[[length(x)]], class)
17	5x	if (isFALSE(check)) {
18	4x	return(sprintf("This is not a picks object that ends in %s", class))
19		}
20	1x	check
21		}
22
23		#' @export
24		#' @rdname assert_last_level
25		assert_last_level <- checkmate::makeAssertionFunction(check_last_level)

1		.onLoad <- function(libname, pkgname) { # nolint
2		# Set up the teal logger instance
3	!	teal.logger::register_logger("teal.slice")
4	!	teal.logger::register_handlers("teal.slice")
5
6		# Manual import instead of using backports and adding 1 more dependency
7	!	if (getRversion() < "4.4") {
8	!	assign("%\|\|%", rlang::`%\|\|%`, envir = getNamespace(pkgname))
9		}
10
11	!	invisible()
12		}