teal.picks coverage - 94.69%

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

  is_choices_delayed <- rlang::is_quosure(x$choices) || .is_predicate(x$choices)
  is_selected_eager <- is.character(x$selected)
  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))
  }

  default_fns <- identical(deparse1(x$selected), deparse1(function(x) !is.na(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"),
      warn = !default_fns
    )
  }

  # 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) {
        label <- attr(data[[choice]], "label", exact = TRUE)
        if (checkmate::test_string(label)) {
          label
        } else {
          choice
        }
      },
      FUN.VALUE = character(1)
    )
    stats::setNames(out, labels)
  } else {
    out
  }
}

#' @rdname dot-determine_choices
.determine_selected <- function(x, data, multiple = FALSE, warn = TRUE) {
  if (!is.null(x) && length(data)) {
    out <- .determine_delayed(data = data, x = x)
    if (!isTRUE(multiple) && length(out) > 1) {
      if (warn) {
        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(
      warningCondition(
        paste0(
          "None of the `choices/selected`: ", rlang::as_label(x), "\n",
          "are subset of: ", toString(.possible_choices(data), width = 30), "\n",
          "Emptying choices...",
          if (!is.function(x) && !rlang::is_quosure(x)) "\nSetting explicit requirements might be the cause."
        ),
        class = c("pick_delayed", "picks_delayed")
      )
    )
    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")
    }
  )
}

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

#' 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. Required when `picks` is a single `picks` object.
#'
#' Only when `picks` is a named list, `id` is optional and can be `NULL` or `""`:
#' - If provided, it is used as a namespace prefix for each list element, so the
#'   input IDs become `<id>-<name>`.
#' - If `NULL` or `""`, the names of the list elements are used directly as the input IDs.
#'   This allows each element to be placed separately in a custom UI (e.g. with
#'   `picks_ui(id = "<name>", picks = picks[["<name>"]])`), while still resolving
#'   all of them with a single `picks_srv()` call.
#' @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") {
  UseMethod("picks_ui", picks)
}

#' @rdname picks_module
#' @export
picks_ui.list <- function(id = "", picks, container = "badge_dropdown") {
  checkmate::assert_list(picks, names = "unique", types = "picks")
  checkmate::assert_string(id, null.ok = TRUE)
  if (identical(id, "")) {
    id <- NULL
  }
  ns <- shiny::NS(id)
  out <- lapply(
    Filter(length, names(picks)),
    function(name) picks_ui(ns(name), picks[[name]], container = container)
  )
  htmltools::tagList(out)
}

#' @rdname picks_module
#' @export
picks_ui.picks <- function(id, picks, container = "badge_dropdown") {
  checkmate::assert_string(id)
  checkmate::assert_class(picks, "picks")
  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))))
  fixed <- all(vapply(picks, is_pick_fixed, logical(1)))

  if (fixed && missing(container)) {
    container <- "badge_fixed"
  }
  if (is.character(container)) {
    container <- get(container, mode = "function")
  }
  out <- container(content, id = ns("inputs"), label = badge_label)
  if (!(methods::is(out, "shiny.tag") || methods::is(out, "shiny.tag.list"))) {
    stop("`container` should be one of `htmltools::tags` or generate one.")
  }
  htmltools::tags$div(out)
}

#' @rdname picks_module
#' @export
picks_srv <- function(id, picks, data) {
  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")
  checkmate::assert_string(id, null.ok = TRUE)
  if (identical(trimws(id), "")) {
    id <- NULL
  }
  ns <- shiny::NS(id)
  sapply(
    names(Filter(length, picks)),
    USE.NAMES = TRUE,
    function(name) picks_srv(ns(name), picks[[name]], data)
  )
}

#' @rdname picks_module
#' @export
picks_srv.picks <- function(id, picks, data) {
  checkmate::assert_named(picks, type = "unique")
  checkmate::assert_string(id)
  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", exact = TRUE)
            paste(
              icon,
              choice,
              if (!is.null(label) && checkmate::test_string(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"

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

#' 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`).
#' @examplesIf requireNamespace("teal.transform", quietly = TRUE)
#'
#' # 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
#' @examplesIf requireNamespace("teal.transform", quietly = TRUE)
#' # 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)
}

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

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

#' Assert picks contains a specific element
#'
#' Check whether a `picks` object contains at least one element of the given
#' class (`"datasets"`, `"variables"`, or `"values"`).
#'
#' @param x `picks` object
#' @param datasets (`logical(1)`) whether to check for the presence of a `datasets` element.
#' @param variables (`logical(1)`) whether to check for the presence of a `variables` element
#' @param values (`logical(1)`) whether to check for the presence of a `values` element
#' @inheritParams checkmate::makeAssertionFunction
#' @inheritParams checkmate::assert
#' @rdname assert_picks
#' @returns For `check_picks` a logical value or a string.
#' For `assert_picks` invisibly the object checked or an error.
#' @examples
#' p <- picks(datasets(), variables(), values())
#' assert_picks(p, datasets = TRUE)
#' assert_picks(p, variables = TRUE)
#' assert_picks(p, values = TRUE)
#'
#' p <- picks(datasets(), variables())
#' check_picks(p, values = TRUE)
#' @export
check_picks <- function(x, datasets = TRUE, variables = FALSE, values = FALSE) {
  checkmate::assert_flag(datasets)
  checkmate::assert_flag(variables)
  checkmate::assert_flag(values)

  if (!inherits(x, "picks")) {
    return(sprintf("Must be a 'picks' object, not '%s'", class(x)[1]))
  }

  if (
    (datasets || variables || values) &&
      (length(x) < 1 || !inherits(x[[1]], "datasets"))
  ) {
    return("Must have datasets() as the first element")
  }

  if ((variables || values) && (length(x) < 2 || !inherits(x[[2]], "variables"))) {
    return("Must have variables() as the second element")
  }

  if (values && (length(x) < 3 || !inherits(x[[3]], "values"))) {
    return("Must have values() as the third element")
  }

  if (length(x) > 3) {
    return("Cannot contain more than 3 elements")
  }

  if (any(!names(x) %in% c("datasets", "variables", "values"))) {
    return("Has invalid names in object, can only contain 'datasets', 'variables', and 'values'")
  }

  # Check if values exists and is preceded by variables
  element_classes <- vapply(x, FUN = methods::is, FUN.VALUE = character(1))
  values_idx <- which(element_classes == "values")

  if (length(values_idx) > 0) {
    variables_idx <- which(element_classes == "variables")
    if (length(variables_idx) == 0) {
      return("picks() requires variables() before values()")
    }
    if (values_idx != variables_idx + 1) {
      return("values() must immediately follow variables() in picks()")
    }
  }

  TRUE
}

#' @export
#' @rdname assert_picks
assert_picks <- checkmate::makeAssertionFunction(check_picks)

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

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

#' Extract datanames from list of picks
#'
#' Helper to decide which datanames are needed for a teal module from the user input.
#' @param ... One or more picks object.
#' @returns The names of the datasets used
#' @export
#' @examples
#' picks_datanames(
#'   picks(
#'     datasets("ADSL", "ADSL"),
#'     variables("SEX")
#'   ),
#'   picks(datasets("ADTTE", "ADTTE"))
#' )
picks_datanames <- function(...) {
  x <- rlang::dots_list(...)
  checkmate::assert_list(x, c("picks", "NULL"))
  datanames_list <- lapply(x, function(x) {
    if (is.character(x$datasets$choices)) {
      x$datasets$choices
    } else {
      NULL
    }
  })

  if (any(vapply(datanames_list, is.null, logical(1)))) {
    "all"
  } else {
    unique(unlist(datanames_list))
  }
}

#' Creation of picks object that does not override a dataset if already exists
#'
#' `r lifecycle::badge("experimental")`
#' Utility function for applying a user-input for variables to the data selected.
#' @param datasets ([`teal.picks::datasets()`] object) to use if `x` does not already have a dataset.
#' @param x (`pick` or `picks` object) to ensure has a dataset.
#' @param ... (`pick` or `picks` object) that will be appended to the `datasets`.
#' @return a `picks` object with a dataset, either from `x` or from `datasets` and other information added.
#' @export
#' @examples
#' ensure_picks_datasets("ADTTE", x = picks(datasets("ADSL", "ADSL"), variables("SEX")))
#' ensure_picks_datasets(datasets("ADSL", "ADSL"), x = variables("SEX", "SEX"))
#' ensure_picks_datasets(datasets("ADSL", "ADSL"),
#'   x = variables("SEX", "SEX"),
#'   values(c("F", "M"), "F")
#' )
ensure_picks_datasets <- function(datasets = NULL, x, ...) {
  if (inherits(x, "picks") && !is.null(x$datasets) || is.null(x)) {
    return(x)
  }
  checkmate::assert_class(datasets, "datasets", null.ok = FALSE)
  checkmate::assert_multi_class(x, c("pick", "picks"))
  dots_arg <- rlang::dots_list(...)
  checkmate::assert_list(dots_arg, types = c("pick", "picks"), unique = TRUE, null.ok = TRUE)


  if (inherits(x, "picks")) {
    picks_args <- c(list(datasets, x$variables, x$values), dots_arg)
    do.call(
      teal.picks::picks,
      picks_args[vapply(picks_args, Negate(is.null), logical(1L))],
    )
  } else if (inherits(x, "pick")) {
    repated_pick <- vapply(dots_arg, function(p) {
      class(p)[1] %in% class(x)[1]
    }, TRUE)
    if (any(repated_pick)) {
      stop("Some pick is repeated: avoid them on ...")
    }
    do.call(teal.picks::picks, c(list(datasets, x), dots_arg))
  }
}

#' 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()),
            output_name = output_name
          )$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), output_name = output_name)

  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 <- union(this_primary_keys, 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[output_name, 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, output_name) {
  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
  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[[output_name]])) {
            # ↓ 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 = output_name, 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, output_name] # 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, output_name))
  }

  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
}

# Escape a string for use as a JavaScript double-quoted literal (ids, Shiny input names, values).
.teal_picks_js_id_literal <- function(id) { # nolint: object_length_linter, line_length_linter.
  id <- gsub("\\", "\\\\", id, fixed = TRUE)
  id <- gsub("\"", "\\\"", id, fixed = TRUE)
  id <- gsub("\r", "\\r", id, fixed = TRUE)
  id <- gsub("\n", "\\n", id, fixed = TRUE)
  paste0("\"", id, "\"")
}

# JSON `[]`, a JSON string, or JSON string array for embedded JS (see `singleton_as_bare_string`).
#
# When `singleton_as_bare_string` is `TRUE` and `length(val) == 1L`, return a single JSON string
# token (e.g. `"foo"`). Otherwise return a JSON array (`[]`, `["a"]`, or `["a","b"]`). The
# always-array form is used where `const arr = ...` must remain an array (`DOM`` sync script).
.teal_picks_js_json_collection_literal <- function(val, singleton_as_bare_string = FALSE) { # nolint: object_length_linter, line_length_linter.
  val <- as.character(val)
  if (length(val) == 0L) {
    return("[]")
  }
  parts <- vapply(val, .teal_picks_js_id_literal, character(1))
  if (isTRUE(singleton_as_bare_string) && length(val) == 1L) {
    return(parts[[1L]])
  }
  paste0("[", paste(parts, collapse = ","), "]")
}

# Scalar string or character vector for `AppDriver$set_inputs()` (empty multi-select: `character(0)`).
.teal_picks_shiny_selected_value_for_set_inputs <- function(val) { # nolint: object_length_linter.
  val <- as.character(val)
  if (length(val) == 0L) {
    character(0)
  } else if (length(val) == 1L) {
    val[[1L]]
  } else {
    val
  }
}

# Sync native <select> + bootstrap-select widget, then let Shiny read change events.
.teal_picks_apply_select_value_in_browser <- function(app_driver, select_id, val) { # nolint: object_length_linter.
  checkmate::assert_string(select_id)
  val <- as.character(val)
  id_lit <- .teal_picks_js_id_literal(select_id)
  arr_lit <- .teal_picks_js_json_collection_literal(val)
  app_driver$run_js(sprintf(
    paste0(
      "(() => {\n",
      "  const sel = document.getElementById(%s);\n",
      "  if (!sel) return false;\n",
      "  const arr = %s;\n",
      "  if (sel.multiple) {\n",
      "    const wanted = new Set(arr);\n",
      "    for (const o of sel.options) o.selected = wanted.has(o.value);\n",
      "  } else {\n",
      "    sel.value = arr.length ? arr[0] : '';\n",
      "  }\n",
      "  if (window.jQuery && jQuery(sel).data('selectpicker')) {\n",
      "    if (sel.multiple) {\n",
      "      jQuery(sel).selectpicker('val', arr);\n",
      "    } else {\n",
      "      jQuery(sel).selectpicker('val', arr.length ? arr[0] : '');\n",
      "    }\n",
      "    jQuery(sel).selectpicker('refresh');\n",
      "  }\n",
      "  sel.dispatchEvent(new Event('input', { bubbles: true }));\n",
      "  sel.dispatchEvent(new Event('change', { bubbles: true }));\n",
      "  return true;\n",
      "})()"
    ),
    id_lit,
    arr_lit
  ))
  invisible(app_driver)
}

# Push values through Shiny and force teal.picks picker commit (`*_open` TRUE then FALSE).
# Uses [`AppDriver$set_inputs()`] with `priority_ = "event"` and `allow_no_input_binding_ = TRUE`
# so shinytest2 waits for the last flush (unbound picker inputs).
.teal_picks_shiny_set_picker_and_commit <- function(app_driver, sel_id, open_id, val) { # nolint: object_length_linter.
  checkmate::assert_string(sel_id)
  checkmate::assert_string(open_id)
  val <- as.character(val)
  sel_value <- .teal_picks_shiny_selected_value_for_set_inputs(val)

  do_call_set_inputs <- function(named_inputs, wait_) {
    do.call(
      app_driver$set_inputs,
      c(
        named_inputs,
        list(
          priority_ = "event",
          allow_no_input_binding_ = TRUE,
          wait_ = wait_
        )
      )
    )
  }

  do_call_set_inputs(stats::setNames(list(sel_value), sel_id), wait_ = FALSE)
  do_call_set_inputs(stats::setNames(list(TRUE), open_id), wait_ = FALSE)
  do_call_set_inputs(stats::setNames(list(FALSE), open_id), wait_ = TRUE)
  invisible(app_driver)
}

# Click the teal.picks summary badge (toggles the dropdown open/closed).
# Use document.querySelector via run_js (Runtime.evaluate) instead of AppDriver$click(CSS) or
# getElementById: Chromote CDP DOM commands can return error -32000 for some selectors in CI.
# The badge ID ends with "-<pick_id>-inputs-summary_badge" regardless of the teal module namespace.
.teal_picks_click_summary_badge <- function(app_driver, pick_id) { # nolint: object_length_linter.
  checkmate::assert_string(pick_id)
  sel_lit <- .teal_picks_js_id_literal(sprintf('[id$="-%s-inputs-summary_badge"]', pick_id))
  app_driver$wait_for_js(sprintf("document.querySelector(%s) !== null", sel_lit))
  app_driver$run_js(sprintf(
    "(function() { var el = document.querySelector(%s); if (el) el.click(); })()",
    sel_lit
  ))
  app_driver$wait_for_idle()
  invisible(app_driver)
}

#' Read the selected values from a categorical teal.picks slot.
#'
#' While the summary badge has never been opened, picker inputs are not bound.
#' This helper reads the committed values from exported picks state.
#' Use this helper only for tests and development workflows.
#'
#' @param app_driver App driver object.
#' @param pick_id `character(1)` teal.picks id.
#' @param slot `character(1)` slot name. Defaults to `"variables"`.
#'
#' @return Selected value(s) for the requested slot.
#' @examples
#' \dontrun{
#' if (requireNamespace("shinytest2", quietly = TRUE)) {
#'   data <- within(teal.data::teal_data(), iris <- iris)
#'   test_picks <- picks(
#'     datasets("iris"),
#'     variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length")
#'   )
#'   teal_app <- teal::init(
#'     data = data,
#'     modules = teal::modules(tm_merge(label = "badge test", picks = list(pick = test_picks)))
#'   )
#'   app_driver <- suppressWarnings(shinytest2::AppDriver$new(
#'     shiny::shinyApp(ui = teal_app$ui, server = teal_app$server)
#'   ))
#'   on.exit(app_driver$stop())
#'   app_driver$wait_for_idle()
#'   app_driver_get_teal_picks_slot(app_driver, "pick", "variables")
#' }
#' }
#'
#' @export
app_driver_get_teal_picks_slot <- function(app_driver, pick_id, slot = "variables") {
  checkmate::assert_class(app_driver, "AppDriver")
  checkmate::assert_string(pick_id)
  checkmate::assert_string(slot)
  selected_pick <- app_driver_teal_picks_exports(app_driver, pick_id)[["picks_resolved"]]
  selected_pick[[slot]]$selected
}

#' Read all teal.picks exported values for a module namespace.
#'
#' The module namespace is inferred from the summary badge id in the `DOM`,
#' then used to filter exported values.
#' Use this helper only for tests and development workflows.
#'
#' @param app_driver App driver object.
#' @param pick_id `character(1)` teal.picks id.
#'
#' @return Named list of module-scoped exported values.
#' @examples
#' \dontrun{
#' if (requireNamespace("shinytest2", quietly = TRUE)) {
#'   data <- within(teal.data::teal_data(), iris <- iris)
#'   test_picks <- picks(
#'     datasets("iris"),
#'     variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length")
#'   )
#'   teal_app <- teal::init(
#'     data = data,
#'     modules = teal::modules(tm_merge(label = "badge test", picks = list(pick = test_picks)))
#'   )
#'   app_driver <- suppressWarnings(shinytest2::AppDriver$new(
#'     shiny::shinyApp(ui = teal_app$ui, server = teal_app$server)
#'   ))
#'   on.exit(app_driver$stop())
#'   app_driver$wait_for_idle()
#'   names(app_driver_teal_picks_exports(app_driver, "pick"))
#' }
#' }
#'
#' @export
app_driver_teal_picks_exports <- function(app_driver, pick_id) {
  checkmate::assert_class(app_driver, "AppDriver")
  checkmate::assert_string(pick_id)
  sel_lit <- .teal_picks_js_id_literal(sprintf('[id$="-%s-inputs-summary_badge"]', pick_id))
  badge_id <- app_driver$get_js(sprintf(
    "(function() { var el = document.querySelector(%s); return el ? el.id : null; })()",
    sel_lit
  ))
  module_ns <- sub("-inputs-summary_badge$", "", badge_id)
  exports <- app_driver$get_values(export = TRUE)$export
  exports_filtered <- exports[grepl(sprintf("^%s-", module_ns), names(exports))]
  names(exports_filtered) <- sub(sprintf("^%s-", module_ns), "", names(exports_filtered))
  exports_filtered
}

#' Set a categorical teal.picks slot value.
#'
#' This helper synchronizes native and bootstrap-select state and commits via
#' the teal.picks open/close input pulse.
#' Use this helper only for tests and development workflows.
#'
#' @param app_driver App driver object.
#' @param pick_id `character(1)` teal.picks id.
#' @param slot `character(1)` slot name.
#' @param value `NULL` or character vector of selected values.
#' @param wait `logical(1)` if `TRUE`, wait for idle after commit.
#'
#' @return Invisibly returns `app_driver`.
#' @examples
#' \dontrun{
#' if (requireNamespace("shinytest2", quietly = TRUE)) {
#'   data <- within(teal.data::teal_data(), iris <- iris)
#'   test_picks <- picks(
#'     datasets("iris"),
#'     variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length")
#'   )
#'   teal_app <- teal::init(
#'     data = data,
#'     modules = teal::modules(tm_merge(label = "badge test", picks = list(pick = test_picks)))
#'   )
#'   app_driver <- suppressWarnings(shinytest2::AppDriver$new(
#'     shiny::shinyApp(ui = teal_app$ui, server = teal_app$server)
#'   ))
#'   on.exit(app_driver$stop())
#'   app_driver$wait_for_idle()
#'   app_driver_set_teal_picks_slot(app_driver, "pick", "variables", "Sepal.Width")
#'   app_driver_get_teal_picks_slot(app_driver, "pick", "variables")
#' }
#' }
#'
#' @export
app_driver_set_teal_picks_slot <- function(app_driver, pick_id, slot, value, wait = TRUE) {
  checkmate::assert_class(app_driver, "AppDriver")
  checkmate::assert_string(pick_id)
  checkmate::assert_string(slot)
  checkmate::assert_flag(wait)
  .teal_picks_click_summary_badge(app_driver, pick_id)
  exports <- app_driver_teal_picks_exports(app_driver, pick_id)
  sel_id <- sprintf(exports$selected_id_fmt, slot)
  open_id <- sprintf(exports$open_id_fmt, slot)
  val <- if (is.null(value)) character(0L) else as.character(value)
  .teal_picks_apply_select_value_in_browser(app_driver, sel_id, val)
  .teal_picks_shiny_set_picker_and_commit(app_driver, sel_id, open_id, val)
  if (isTRUE(wait)) {
    app_driver$wait_for_idle()
  }
  .teal_picks_click_summary_badge(app_driver, pick_id)
  invisible(app_driver)
}

#' Expect that a CSS selector resolves to at least one visible element.
#'
#' Use this helper only for tests and development workflows.
#'
#' @param selector `character(1)` CSS selector to check.
#' @param app_driver App driver object.
#' @param timeout `numeric(1)` maximum wait time.
#'
#' @return Called expectation result.
#' @examples
#' \dontrun{
#' if (requireNamespace("shinytest2", quietly = TRUE)) {
#'   data <- within(teal.data::teal_data(), iris <- iris)
#'   test_picks <- picks(
#'     datasets("iris"),
#'     variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length")
#'   )
#'   teal_app <- teal::init(
#'     data = data,
#'     modules = teal::modules(tm_merge(label = "badge test", picks = list(pick = test_picks)))
#'   )
#'   app_driver <- suppressWarnings(shinytest2::AppDriver$new(
#'     shiny::shinyApp(ui = teal_app$ui, server = teal_app$server)
#'   ))
#'   app_driver$wait_for_idle()
#'   app_driver_expect_picks_hidden("[id$='inputs_container']", app_driver, timeout = 1000)
#'   app_driver$click(selector = "[id$='inputs-summary_badge']")
#'   app_driver_expect_picks_visible("[id$='inputs_container']", app_driver, timeout = 1000)
#'   app_driver$stop()
#' }
#' }
#'
#' @export
app_driver_expect_picks_visible <- function(selector, app_driver, timeout) { # nolint: object_length_linter.
  checkmate::assert_class(app_driver, "AppDriver")
  checkmate::assert_string(selector)
  selector <- .teal_picks_js_id_literal(selector)

  tryCatch(
    {
      app_driver$wait_for_js(
        sprintf(
          paste0(
            "Array.from(document.querySelectorAll(%s))",
            ".map(function(el) {",
            "  var cs = window.getComputedStyle(el);",
            "  return cs.display !== 'none' && cs.visibility !== 'hidden' &&",
            "    el.style.opacity !== '0' &&",
            "    (el.textContent.trim().length > 0 || el.children.length > 0);",
            "})",
            ".some(Boolean)"
          ),
          selector
        ),
        timeout
      )
      testthat::succeed()
    },
    error = function(err) {
      testthat::fail(sprintf("CSS selector '%s' does not produce any visible elements.", selector))
    }
  )
}

#' @describeIn app_driver_expect_picks_visible Check if a selector is hidden for a given timeout.
#' @export
app_driver_expect_picks_hidden <- function(selector, app_driver, timeout) {
  checkmate::assert_class(app_driver, "AppDriver")
  checkmate::assert_string(selector)
  selector <- .teal_picks_js_id_literal(selector)
  tryCatch(
    {
      app_driver$wait_for_js(
        sprintf(
          paste0(
            "!Array.from(document.querySelectorAll(%s))",
            ".map(function(el) {",
            "  var cs = window.getComputedStyle(el);",
            "  return cs.display !== 'none' && cs.visibility !== 'hidden' &&",
            "    el.style.opacity !== '0' &&",
            "    (el.textContent.trim().length > 0 || el.children.length > 0);",
            "})",
            ".some(Boolean)"
          ),
          selector
        ),
        timeout
      )
      testthat::succeed()
    },
    error = function(err) {
      testthat::fail(sprintf("CSS selector '%s' produces visible elements.", selector))
    }
  )
}

#' 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		#' @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		#' `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	219x	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		#' 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		#' 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)
26
27		#' Assert picks contains a specific element
28		#'
29		#' Check whether a `picks` object contains at least one element of the given
30		#' class (`"datasets"`, `"variables"`, or `"values"`).
31		#'
32		#' @param x `picks` object
33		#' @param datasets (`logical(1)`) whether to check for the presence of a `datasets` element.
34		#' @param variables (`logical(1)`) whether to check for the presence of a `variables` element
35		#' @param values (`logical(1)`) whether to check for the presence of a `values` element
36		#' @inheritParams checkmate::makeAssertionFunction
37		#' @inheritParams checkmate::assert
38		#' @rdname assert_picks
39		#' @returns For `check_picks` a logical value or a string.
40		#' For `assert_picks` invisibly the object checked or an error.
41		#' @examples
42		#' p <- picks(datasets(), variables(), values())
43		#' assert_picks(p, datasets = TRUE)
44		#' assert_picks(p, variables = TRUE)
45		#' assert_picks(p, values = TRUE)
46		#'
47		#' p <- picks(datasets(), variables())
48		#' check_picks(p, values = TRUE)
49		#' @export
50		check_picks <- function(x, datasets = TRUE, variables = FALSE, values = FALSE) {
51	236x	checkmate::assert_flag(datasets)
52	236x	checkmate::assert_flag(variables)
53	236x	checkmate::assert_flag(values)
54
55	236x	if (!inherits(x, "picks")) {
56	3x	return(sprintf("Must be a 'picks' object, not '%s'", class(x)[1]))
57		}
58
59		if (
60	233x	(datasets \|\| variables \|\| values) &&
61	233x	(length(x) < 1 \|\| !inherits(x[[1]], "datasets"))
62		) {
63	2x	return("Must have datasets() as the first element")
64		}
65
66	231x	if ((variables \|\| values) && (length(x) < 2 \|\| !inherits(x[[2]], "variables"))) {
67	2x	return("Must have variables() as the second element")
68		}
69
70	229x	if (values && (length(x) < 3 \|\| !inherits(x[[3]], "values"))) {
71	3x	return("Must have values() as the third element")
72		}
73
74	226x	if (length(x) > 3) {
75	!	return("Cannot contain more than 3 elements")
76		}
77
78	226x	if (any(!names(x) %in% c("datasets", "variables", "values"))) {
79	!	return("Has invalid names in object, can only contain 'datasets', 'variables', and 'values'")
80		}
81
82		# Check if values exists and is preceded by variables
83	226x	element_classes <- vapply(x, FUN = methods::is, FUN.VALUE = character(1))
84	226x	values_idx <- which(element_classes == "values")
85
86	226x	if (length(values_idx) > 0) {
87	69x	variables_idx <- which(element_classes == "variables")
88	69x	if (length(variables_idx) == 0) {
89	1x	return("picks() requires variables() before values()")
90		}
91	68x	if (values_idx != variables_idx + 1) {
92	1x	return("values() must immediately follow variables() in picks()")
93		}
94		}
95
96	224x	TRUE
97		}
98
99		#' @export
100		#' @rdname assert_picks
101		assert_picks <- checkmate::makeAssertionFunction(check_picks)

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	22x	teal::module(
44	22x	label = label,
45	22x	ui = function(id, picks) {
46	10x	ns <- shiny::NS(id)
47	10x	tags$div(
48	10x	tags$div(
49	10x	class = "row g-2",
50	10x	lapply(names(picks), function(pick_name) {
51	12x	tags$div(
52	12x	class = "col-auto",
53	12x	tags$strong(tags$label(pick_name)),
54	12x	teal.picks::picks_ui(
55	12x	id = ns(pick_name),
56	12x	picks = picks[[pick_name]]
57		)
58		)
59		})
60		),
61	10x	shiny::div(
62	10x	shiny::tags$label("Join keys"),
63	10x	shiny::verbatimTextOutput(ns("join_keys")),
64	10x	shiny::tags$label("Mapped"),
65	10x	shiny::verbatimTextOutput(ns("mapped")),
66	10x	shiny::tags$label("Source code"),
67	10x	shiny::verbatimTextOutput(ns("src")),
68	10x	shiny::tags$label("Merge result"),
69	10x	shiny::tableOutput(ns("table_merged"))
70		)
71		)
72		},
73	22x	server = function(id, data, picks) {
74	8x	shiny::moduleServer(id, function(input, output, session) {
75	8x	selectors <- picks_srv(NULL, picks = picks, data = data)
76
77	8x	merged <- merge_srv("merge", data = data, selectors = selectors)
78
79	8x	table_q <- shiny::reactive({
80	8x	shiny::req(merged$data())
81	8x	within(merged$data(), anl, selectors = selectors)
82		})
83
84	8x	output$table_merged <- shiny::renderTable({
85	7x	shiny::req(table_q())
86	7x	teal.code::get_outputs(table_q())[[1]]
87		})
88
89	8x	output$src <- renderPrint({
90	7x	cat(teal.code::get_code(shiny::req(table_q())))
91		})
92
93	8x	output$mapped <- renderText(yaml::as.yaml(merged$variables()))
94
95	8x	output$join_keys <- renderPrint(teal.data::join_keys(merged$data()))
96
97	8x	table_q
98		})
99		},
100	22x	ui_args = list(picks = picks),
101	22x	server_args = list(picks = picks),
102	22x	transformators = transformators
103		)
104		}

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

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

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	54x	checkmate::assert_class(x, classes = c("pick"))
31	53x	checkmate::assert_flag(attr(x, "fixed", exact = TRUE))
32	53x	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		}
47
48		#' Extract datanames from list of picks
49		#'
50		#' Helper to decide which datanames are needed for a teal module from the user input.
51		#' @param ... One or more picks object.
52		#' @returns The names of the datasets used
53		#' @export
54		#' @examples
55		#' picks_datanames(
56		#' picks(
57		#' datasets("ADSL", "ADSL"),
58		#' variables("SEX")
59		#' ),
60		#' picks(datasets("ADTTE", "ADTTE"))
61		#' )
62		picks_datanames <- function(...) {
63	3x	x <- rlang::dots_list(...)
64	3x	checkmate::assert_list(x, c("picks", "NULL"))
65	3x	datanames_list <- lapply(x, function(x) {
66	4x	if (is.character(x$datasets$choices)) {
67	3x	x$datasets$choices
68		} else {
69	1x	NULL
70		}
71		})
72
73	3x	if (any(vapply(datanames_list, is.null, logical(1)))) {
74	1x	"all"
75		} else {
76	2x	unique(unlist(datanames_list))
77		}
78		}
79
80		#' Creation of picks object that does not override a dataset if already exists
81		#'
82		#' `r lifecycle::badge("experimental")`
83		#' Utility function for applying a user-input for variables to the data selected.
84		#' @param datasets ([`teal.picks::datasets()`] object) to use if `x` does not already have a dataset.
85		#' @param x (`pick` or `picks` object) to ensure has a dataset.
86		#' @param ... (`pick` or `picks` object) that will be appended to the `datasets`.
87		#' @return a `picks` object with a dataset, either from `x` or from `datasets` and other information added.
88		#' @export
89		#' @examples
90		#' ensure_picks_datasets("ADTTE", x = picks(datasets("ADSL", "ADSL"), variables("SEX")))
91		#' ensure_picks_datasets(datasets("ADSL", "ADSL"), x = variables("SEX", "SEX"))
92		#' ensure_picks_datasets(datasets("ADSL", "ADSL"),
93		#' x = variables("SEX", "SEX"),
94		#' values(c("F", "M"), "F")
95		#' )
96		ensure_picks_datasets <- function(datasets = NULL, x, ...) {
97	5x	if (inherits(x, "picks") && !is.null(x$datasets) \|\| is.null(x)) {
98	1x	return(x)
99		}
100	4x	checkmate::assert_class(datasets, "datasets", null.ok = FALSE)
101	4x	checkmate::assert_multi_class(x, c("pick", "picks"))
102	4x	dots_arg <- rlang::dots_list(...)
103	4x	checkmate::assert_list(dots_arg, types = c("pick", "picks"), unique = TRUE, null.ok = TRUE)
104
105
106	4x	if (inherits(x, "picks")) {
107	1x	picks_args <- c(list(datasets, x$variables, x$values), dots_arg)
108	1x	do.call(
109	1x	teal.picks::picks,
110	1x	picks_args[vapply(picks_args, Negate(is.null), logical(1L))],
111		)
112	3x	} else if (inherits(x, "pick")) {
113	3x	repated_pick <- vapply(dots_arg, function(p) {
114	2x	class(p)[1] %in% class(x)[1]
115	3x	}, TRUE)
116	3x	if (any(repated_pick)) {
117	1x	stop("Some pick is repeated: avoid them on ...")
118		}
119	2x	do.call(teal.picks::picks, c(list(datasets, x), dots_arg))
120		}
121		}

1		# Escape a string for use as a JavaScript double-quoted literal (ids, Shiny input names, values).
2		.teal_picks_js_id_literal <- function(id) { # nolint: object_length_linter, line_length_linter.
3	10x	id <- gsub("\\", "\\\\", id, fixed = TRUE)
4	10x	id <- gsub("\"", "\\\"", id, fixed = TRUE)
5	10x	id <- gsub("\r", "\\r", id, fixed = TRUE)
6	10x	id <- gsub("\n", "\\n", id, fixed = TRUE)
7	10x	paste0("\"", id, "\"")
8		}
9
10		# JSON `[]`, a JSON string, or JSON string array for embedded JS (see `singleton_as_bare_string`).
11		#
12		# When `singleton_as_bare_string` is `TRUE` and `length(val) == 1L`, return a single JSON string
13		# token (e.g. `"foo"`). Otherwise return a JSON array (`[]`, `["a"]`, or `["a","b"]`). The
14		# always-array form is used where `const arr = ...` must remain an array (`DOM`` sync script).
15		.teal_picks_js_json_collection_literal <- function(val, singleton_as_bare_string = FALSE) { # nolint: object_length_linter, line_length_linter.
16	1x	val <- as.character(val)
17	1x	if (length(val) == 0L) {
18	!	return("[]")
19		}
20	1x	parts <- vapply(val, .teal_picks_js_id_literal, character(1))
21	1x	if (isTRUE(singleton_as_bare_string) && length(val) == 1L) {
22	!	return(parts[[1L]])
23		}
24	1x	paste0("[", paste(parts, collapse = ","), "]")
25		}
26
27		# Scalar string or character vector for `AppDriver$set_inputs()` (empty multi-select: `character(0)`).
28		.teal_picks_shiny_selected_value_for_set_inputs <- function(val) { # nolint: object_length_linter.
29	1x	val <- as.character(val)
30	1x	if (length(val) == 0L) {
31	!	character(0)
32	1x	} else if (length(val) == 1L) {
33	1x	val[[1L]]
34		} else {
35	!	val
36		}
37		}
38
39		# Sync native <select> + bootstrap-select widget, then let Shiny read change events.
40		.teal_picks_apply_select_value_in_browser <- function(app_driver, select_id, val) { # nolint: object_length_linter.
41	1x	checkmate::assert_string(select_id)
42	1x	val <- as.character(val)
43	1x	id_lit <- .teal_picks_js_id_literal(select_id)
44	1x	arr_lit <- .teal_picks_js_json_collection_literal(val)
45	1x	app_driver$run_js(sprintf(
46	1x	paste0(
47	1x	"(() => {\n",
48	1x	" const sel = document.getElementById(%s);\n",
49	1x	" if (!sel) return false;\n",
50	1x	" const arr = %s;\n",
51	1x	" if (sel.multiple) {\n",
52	1x	" const wanted = new Set(arr);\n",
53	1x	" for (const o of sel.options) o.selected = wanted.has(o.value);\n",
54	1x	" } else {\n",
55	1x	" sel.value = arr.length ? arr[0] : '';\n",
56	1x	" }\n",
57	1x	" if (window.jQuery && jQuery(sel).data('selectpicker')) {\n",
58	1x	" if (sel.multiple) {\n",
59	1x	" jQuery(sel).selectpicker('val', arr);\n",
60	1x	" } else {\n",
61	1x	" jQuery(sel).selectpicker('val', arr.length ? arr[0] : '');\n",
62	1x	" }\n",
63	1x	" jQuery(sel).selectpicker('refresh');\n",
64	1x	" }\n",
65	1x	" sel.dispatchEvent(new Event('input', { bubbles: true }));\n",
66	1x	" sel.dispatchEvent(new Event('change', { bubbles: true }));\n",
67	1x	" return true;\n",
68		"})()"
69		),
70	1x	id_lit,
71	1x	arr_lit
72		))
73	1x	invisible(app_driver)
74		}
75
76		# Push values through Shiny and force teal.picks picker commit (`*_open` TRUE then FALSE).
77		# Uses [`AppDriver$set_inputs()`] with `priority_ = "event"` and `allow_no_input_binding_ = TRUE`
78		# so shinytest2 waits for the last flush (unbound picker inputs).
79		.teal_picks_shiny_set_picker_and_commit <- function(app_driver, sel_id, open_id, val) { # nolint: object_length_linter.
80	1x	checkmate::assert_string(sel_id)
81	1x	checkmate::assert_string(open_id)
82	1x	val <- as.character(val)
83	1x	sel_value <- .teal_picks_shiny_selected_value_for_set_inputs(val)
84
85	1x	do_call_set_inputs <- function(named_inputs, wait_) {
86	3x	do.call(
87	3x	app_driver$set_inputs,
88	3x	c(
89	3x	named_inputs,
90	3x	list(
91	3x	priority_ = "event",
92	3x	allow_no_input_binding_ = TRUE,
93	3x	wait_ = wait_
94		)
95		)
96		)
97		}
98
99	1x	do_call_set_inputs(stats::setNames(list(sel_value), sel_id), wait_ = FALSE)
100	1x	do_call_set_inputs(stats::setNames(list(TRUE), open_id), wait_ = FALSE)
101	1x	do_call_set_inputs(stats::setNames(list(FALSE), open_id), wait_ = TRUE)
102	1x	invisible(app_driver)
103		}
104
105		# Click the teal.picks summary badge (toggles the dropdown open/closed).
106		# Use document.querySelector via run_js (Runtime.evaluate) instead of AppDriver$click(CSS) or
107		# getElementById: Chromote CDP DOM commands can return error -32000 for some selectors in CI.
108		# The badge ID ends with "-<pick_id>-inputs-summary_badge" regardless of the teal module namespace.
109		.teal_picks_click_summary_badge <- function(app_driver, pick_id) { # nolint: object_length_linter.
110	2x	checkmate::assert_string(pick_id)
111	2x	sel_lit <- .teal_picks_js_id_literal(sprintf('[id$="-%s-inputs-summary_badge"]', pick_id))
112	2x	app_driver$wait_for_js(sprintf("document.querySelector(%s) !== null", sel_lit))
113	2x	app_driver$run_js(sprintf(
114	2x	"(function() { var el = document.querySelector(%s); if (el) el.click(); })()",
115	2x	sel_lit
116		))
117	2x	app_driver$wait_for_idle()
118	2x	invisible(app_driver)
119		}
120
121		#' Read the selected values from a categorical teal.picks slot.
122		#'
123		#' While the summary badge has never been opened, picker inputs are not bound.
124		#' This helper reads the committed values from exported picks state.
125		#' Use this helper only for tests and development workflows.
126		#'
127		#' @param app_driver App driver object.
128		#' @param pick_id `character(1)` teal.picks id.
129		#' @param slot `character(1)` slot name. Defaults to `"variables"`.
130		#'
131		#' @return Selected value(s) for the requested slot.
132		#' @examples
133		#' \dontrun{
134		#' if (requireNamespace("shinytest2", quietly = TRUE)) {
135		#' data <- within(teal.data::teal_data(), iris <- iris)
136		#' test_picks <- picks(
137		#' datasets("iris"),
138		#' variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length")
139		#' )
140		#' teal_app <- teal::init(
141		#' data = data,
142		#' modules = teal::modules(tm_merge(label = "badge test", picks = list(pick = test_picks)))
143		#' )
144		#' app_driver <- suppressWarnings(shinytest2::AppDriver$new(
145		#' shiny::shinyApp(ui = teal_app$ui, server = teal_app$server)
146		#' ))
147		#' on.exit(app_driver$stop())
148		#' app_driver$wait_for_idle()
149		#' app_driver_get_teal_picks_slot(app_driver, "pick", "variables")
150		#' }
151		#' }
152		#'
153		#' @export
154		app_driver_get_teal_picks_slot <- function(app_driver, pick_id, slot = "variables") {
155	2x	checkmate::assert_class(app_driver, "AppDriver")
156	2x	checkmate::assert_string(pick_id)
157	2x	checkmate::assert_string(slot)
158	2x	selected_pick <- app_driver_teal_picks_exports(app_driver, pick_id)[["picks_resolved"]]
159	2x	selected_pick[[slot]]$selected
160		}
161
162		#' Read all teal.picks exported values for a module namespace.
163		#'
164		#' The module namespace is inferred from the summary badge id in the `DOM`,
165		#' then used to filter exported values.
166		#' Use this helper only for tests and development workflows.
167		#'
168		#' @param app_driver App driver object.
169		#' @param pick_id `character(1)` teal.picks id.
170		#'
171		#' @return Named list of module-scoped exported values.
172		#' @examples
173		#' \dontrun{
174		#' if (requireNamespace("shinytest2", quietly = TRUE)) {
175		#' data <- within(teal.data::teal_data(), iris <- iris)
176		#' test_picks <- picks(
177		#' datasets("iris"),
178		#' variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length")
179		#' )
180		#' teal_app <- teal::init(
181		#' data = data,
182		#' modules = teal::modules(tm_merge(label = "badge test", picks = list(pick = test_picks)))
183		#' )
184		#' app_driver <- suppressWarnings(shinytest2::AppDriver$new(
185		#' shiny::shinyApp(ui = teal_app$ui, server = teal_app$server)
186		#' ))
187		#' on.exit(app_driver$stop())
188		#' app_driver$wait_for_idle()
189		#' names(app_driver_teal_picks_exports(app_driver, "pick"))
190		#' }
191		#' }
192		#'
193		#' @export
194		app_driver_teal_picks_exports <- function(app_driver, pick_id) {
195	4x	checkmate::assert_class(app_driver, "AppDriver")
196	4x	checkmate::assert_string(pick_id)
197	4x	sel_lit <- .teal_picks_js_id_literal(sprintf('[id$="-%s-inputs-summary_badge"]', pick_id))
198	4x	badge_id <- app_driver$get_js(sprintf(
199	4x	"(function() { var el = document.querySelector(%s); return el ? el.id : null; })()",
200	4x	sel_lit
201		))
202	4x	module_ns <- sub("-inputs-summary_badge$", "", badge_id)
203	4x	exports <- app_driver$get_values(export = TRUE)$export
204	4x	exports_filtered <- exports[grepl(sprintf("^%s-", module_ns), names(exports))]
205	4x	names(exports_filtered) <- sub(sprintf("^%s-", module_ns), "", names(exports_filtered))
206	4x	exports_filtered
207		}
208
209		#' Set a categorical teal.picks slot value.
210		#'
211		#' This helper synchronizes native and bootstrap-select state and commits via
212		#' the teal.picks open/close input pulse.
213		#' Use this helper only for tests and development workflows.
214		#'
215		#' @param app_driver App driver object.
216		#' @param pick_id `character(1)` teal.picks id.
217		#' @param slot `character(1)` slot name.
218		#' @param value `NULL` or character vector of selected values.
219		#' @param wait `logical(1)` if `TRUE`, wait for idle after commit.
220		#'
221		#' @return Invisibly returns `app_driver`.
222		#' @examples
223		#' \dontrun{
224		#' if (requireNamespace("shinytest2", quietly = TRUE)) {
225		#' data <- within(teal.data::teal_data(), iris <- iris)
226		#' test_picks <- picks(
227		#' datasets("iris"),
228		#' variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length")
229		#' )
230		#' teal_app <- teal::init(
231		#' data = data,
232		#' modules = teal::modules(tm_merge(label = "badge test", picks = list(pick = test_picks)))
233		#' )
234		#' app_driver <- suppressWarnings(shinytest2::AppDriver$new(
235		#' shiny::shinyApp(ui = teal_app$ui, server = teal_app$server)
236		#' ))
237		#' on.exit(app_driver$stop())
238		#' app_driver$wait_for_idle()
239		#' app_driver_set_teal_picks_slot(app_driver, "pick", "variables", "Sepal.Width")
240		#' app_driver_get_teal_picks_slot(app_driver, "pick", "variables")
241		#' }
242		#' }
243		#'
244		#' @export
245		app_driver_set_teal_picks_slot <- function(app_driver, pick_id, slot, value, wait = TRUE) {
246	1x	checkmate::assert_class(app_driver, "AppDriver")
247	1x	checkmate::assert_string(pick_id)
248	1x	checkmate::assert_string(slot)
249	1x	checkmate::assert_flag(wait)
250	1x	.teal_picks_click_summary_badge(app_driver, pick_id)
251	1x	exports <- app_driver_teal_picks_exports(app_driver, pick_id)
252	1x	sel_id <- sprintf(exports$selected_id_fmt, slot)
253	1x	open_id <- sprintf(exports$open_id_fmt, slot)
254	1x	val <- if (is.null(value)) character(0L) else as.character(value)
255	1x	.teal_picks_apply_select_value_in_browser(app_driver, sel_id, val)
256	1x	.teal_picks_shiny_set_picker_and_commit(app_driver, sel_id, open_id, val)
257	1x	if (isTRUE(wait)) {
258	1x	app_driver$wait_for_idle()
259		}
260	1x	.teal_picks_click_summary_badge(app_driver, pick_id)
261	1x	invisible(app_driver)
262		}
263
264		#' Expect that a CSS selector resolves to at least one visible element.
265		#'
266		#' Use this helper only for tests and development workflows.
267		#'
268		#' @param selector `character(1)` CSS selector to check.
269		#' @param app_driver App driver object.
270		#' @param timeout `numeric(1)` maximum wait time.
271		#'
272		#' @return Called expectation result.
273		#' @examples
274		#' \dontrun{
275		#' if (requireNamespace("shinytest2", quietly = TRUE)) {
276		#' data <- within(teal.data::teal_data(), iris <- iris)
277		#' test_picks <- picks(
278		#' datasets("iris"),
279		#' variables(choices = c("Sepal.Length", "Sepal.Width"), selected = "Sepal.Length")
280		#' )
281		#' teal_app <- teal::init(
282		#' data = data,
283		#' modules = teal::modules(tm_merge(label = "badge test", picks = list(pick = test_picks)))
284		#' )
285		#' app_driver <- suppressWarnings(shinytest2::AppDriver$new(
286		#' shiny::shinyApp(ui = teal_app$ui, server = teal_app$server)
287		#' ))
288		#' app_driver$wait_for_idle()
289		#' app_driver_expect_picks_hidden("[id$='inputs_container']", app_driver, timeout = 1000)
290		#' app_driver$click(selector = "[id$='inputs-summary_badge']")
291		#' app_driver_expect_picks_visible("[id$='inputs_container']", app_driver, timeout = 1000)
292		#' app_driver$stop()
293		#' }
294		#' }
295		#'
296		#' @export
297		app_driver_expect_picks_visible <- function(selector, app_driver, timeout) { # nolint: object_length_linter.
298	1x	checkmate::assert_class(app_driver, "AppDriver")
299	1x	checkmate::assert_string(selector)
300	1x	selector <- .teal_picks_js_id_literal(selector)
301
302	1x	tryCatch(
303		{
304	1x	app_driver$wait_for_js(
305	1x	sprintf(
306	1x	paste0(
307	1x	"Array.from(document.querySelectorAll(%s))",
308	1x	".map(function(el) {",
309	1x	" var cs = window.getComputedStyle(el);",
310	1x	" return cs.display !== 'none' && cs.visibility !== 'hidden' &&",
311	1x	" el.style.opacity !== '0' &&",
312	1x	" (el.textContent.trim().length > 0 \|\| el.children.length > 0);",
313		"})",
314	1x	".some(Boolean)"
315		),
316	1x	selector
317		),
318	1x	timeout
319		)
320	1x	testthat::succeed()
321		},
322	1x	error = function(err) {
323	!	testthat::fail(sprintf("CSS selector '%s' does not produce any visible elements.", selector))
324		}
325		)
326		}
327
328		#' @describeIn app_driver_expect_picks_visible Check if a selector is hidden for a given timeout.
329		#' @export
330		app_driver_expect_picks_hidden <- function(selector, app_driver, timeout) {
331	1x	checkmate::assert_class(app_driver, "AppDriver")
332	1x	checkmate::assert_string(selector)
333	1x	selector <- .teal_picks_js_id_literal(selector)
334	1x	tryCatch(
335		{
336	1x	app_driver$wait_for_js(
337	1x	sprintf(
338	1x	paste0(
339	1x	"!Array.from(document.querySelectorAll(%s))",
340	1x	".map(function(el) {",
341	1x	" var cs = window.getComputedStyle(el);",
342	1x	" return cs.display !== 'none' && cs.visibility !== 'hidden' &&",
343	1x	" el.style.opacity !== '0' &&",
344	1x	" (el.textContent.trim().length > 0 \|\| el.children.length > 0);",
345		"})",
346	1x	".some(Boolean)"
347		),
348	1x	selector
349		),
350	1x	timeout
351		)
352	1x	testthat::succeed()
353		},
354	1x	error = function(err) {
355	!	testthat::fail(sprintf("CSS selector '%s' produces visible elements.", selector))
356		}
357		)
358		}

1		.onLoad <- function(libname, pkgname) { # nolint
2		# Set up the teal logger instance
3	1x	teal.logger::register_logger(pkgname)
4	1x	teal.logger::register_handlers(pkgname)
5	1x	invisible()
6		}

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	9x	ns <- shiny::NS(id)
15	9x	htmltools::tagList(
16	9x	htmltools::singleton(htmltools::tags$head(
17	9x	htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.picks")),
18	9x	htmltools::includeScript(system.file("badge-dropdown", "script.js", package = "teal.picks"))
19		)),
20	9x	htmltools::tags$div(
21	9x	class = "badge-wrapper",
22	9x	htmltools::tags$span(
23	9x	id = ns("summary_badge"),
24	9x	class = "badge bg-primary rounded-pill badge-dropdown",
25	9x	style = "cursor: pointer;",
26	9x	tags$span(class = "badge-dropdown-label", label),
27	9x	tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")),
28	9x	onclick = sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container"))
29		),
30	9x	htmltools::tags$div(
31	9x	content,
32	9x	id = ns("inputs_container"),
33	9x	style = htmltools::css(
34	9x	visibility = "hidden",
35	9x	width = "0",
36	9x	position = "fixed",
37	9x	background = "white",
38	9x	border = "1px solid #ccc",
39	9x	`border-radius` = "4px",
40	9x	`box-shadow` = "0 2px 10px rgba(0,0,0,0.1)",
41	9x	padding = "10px",
42	9x	`z-index` = "1050", # z-index set to 1000+50 to ensure that is above encoding panel on 1 column layout.
43	9x	`min-width` = "200px",
44	9x	transition = "opacity 0.2s ease",
45	9x	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	11x	ns <- shiny::NS(id)
58
59	11x	htmltools::tagList(
60	11x	htmltools::singleton(htmltools::tags$head(
61	11x	htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.picks"))
62		)),
63	11x	htmltools::tags$div(
64	11x	class = "badge-wrapper",
65	11x	htmltools::tags$span(
66	11x	id = ns("fixed_badge"),
67	11x	class = "fixed-picks badge-dropdown",
68	11x	htmltools::tags$label(label),
69	11x	htmltools::tags$i(bsicons::bs_icon("lock-fill"))
70		),
71	11x	htmltools::tags$div(
72	11x	id = ns("inputs_container"),
73	11x	class = "zero-width-inputs",
74	11x	content,
75	11x	style = "visibility: hidden; width: 0; height: 0; position: fixed;"
76		)
77		)
78		)
79		}