teal.picks coverage - 85.21%

Files
Source

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

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

#' Interactive picks
#'
#' @description
#'
#' Creates UI and server components for interactive [picks()] in Shiny modules. The module is based on
#' configuration provided via [picks()] and its responsibility is to determine relevant input
#' values
#'
#'
#' The module supports both single and combined `picks`:
#' - Single `picks` objects for a single input
#' - Named lists of `picks` objects for multiple inputs
#'
#' @param id (`character(1)`) Shiny module ID
#' @param picks (`picks` or `list`) object created by `picks()` or a named list of such objects
#' @param container (`character(1)` or `function`) UI container type. Can be one of `htmltools::tags`
#' functions. By default, elements are wrapped in a package-specific drop-down.
#' @param data (`reactive`) Reactive expression returning the data object to be used for populating choices
#'
#' @return
#' - `picks_ui()`: UI elements for the input controls
#' - `picks_srv()`: Server-side reactive logic returning the processed data
#'
#' @details
#' The module uses S3 method dispatch to handle different ways to provide `picks`:
#' - `.picks` methods handle single `picks`` object
#' - `.list` methods handle multiple `picks` objects
#'
#' The UI component (`picks_ui`) creates the visual elements, while the
#' server component (`picks_srv`) manages the reactive logic,
#'
#' @seealso [picks()] for creating `picks`` objects
#'
#' @name picks_module
NULL

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    picks_resolved
  })
}

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

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

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

    output$selected_container <- renderUI({
      logger::log_debug(".pick_srv@1 rerender {pick_type} input")
      .validate_is_eager(choices())
      .validate_is_eager(selected())
      if (!length(choices()) || isTRUE(args$fixed)) {
        NULL
      } 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()) # 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_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`
#' @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`)
#' @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"

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

#' 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.
#'
#' @examples
#' # convert des with eager select_spec
#' as.picks(
#'   teal.transform::data_extract_spec(
#'     dataname = "iris",
#'     teal.transform::select_spec(
#'       choices = c("Sepal.Length", "Sepal.Width", "Species"),
#'       selected = c("Sepal.Length", "Species"),
#'       multiple = TRUE,
#'       ordered = TRUE
#'     )
#'   )
#' )
#'
#' # convert des with delayed select_spec
#' as.picks(
#'   teal.transform::data_extract_spec(
#'     dataname = "iris",
#'     teal.transform::select_spec(
#'       choices = teal.transform::variable_choices("iris"),
#'       selected = teal.transform::first_choice(),
#'       multiple = TRUE,
#'       ordered = TRUE
#'     )
#'   )
#' )
#'
#' as.picks(
#'   teal.transform::data_extract_spec(
#'     dataname = "iris",
#'     teal.transform::select_spec(
#'       choices = teal.transform::variable_choices(
#'         "iris",
#'         subset = function(data) names(Filter(is.numeric, data))
#'       ),
#'       selected = teal.transform::first_choice(),
#'       multiple = TRUE,
#'       ordered = TRUE
#'     )
#'   )
#' )
#'
#' @export
as.picks <- function(x, quiet = FALSE) { # nolint: object_name_linter.
  checkmate::assert_flag(quiet)
  if (inherits(x, c("picks", "pick"))) {
    x
  } else if (checkmate::test_list(x, c("data_extract_spec", "filter_spec"))) {
    Filter(length, lapply(x, as.picks, quiet = quiet))
  } else if (inherits(x, "data_extract_spec")) {
    args <- Filter(
      length,
      list(
        datasets(choices = x$dataname, fixed = TRUE),
        as.picks(x$select, quiet = quiet),
        as.picks(x$filter, quiet = quiet)
      )
    )
    do.call(picks, args)
  } else if (inherits(x, "select_spec")) {
    .select_spec_to_variables(x)
  } else if (inherits(x, "choices_selected")) {
    .choices_selected_to_variables(x)
  } else if (inherits(x, "filter_spec") && !quiet) {
    # filter_spec is necessary linked with `select` (selected variables)
    # so  in most of the cases it can't beconverted into variables/values
    # because filter_spec can be specified on the variable(s) different than select_spec for example (pseudocode):
    #    select_spec "AVAL"
    #    filter_spec "PARAMCD"
    warning(
      "`filter_spec` are not convertible to picks - please use `transformers` argument",
      " and create `teal_transform_module` containing necessary filter. See `?teal_transform_filter`"
    )

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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


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

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

  datasets_vars <- .mapping_input_to_datasets(mapping)

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

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

    # Update data with operators to determine filtering on interaction variables
    for (ix in which(operators_names %in% this_variables)) {
      x <- teal.code::eval_code(
        x,
        substitute(
          obj_name <- .operator_mutate(cols, var_name, obj_name), # nolint: object_usage_linter.
          env = list(
            cols = operators[[ix]],
            var_name = attr(operators[[ix]], "var_name", TRUE),
            obj_name = as.name(dataname)
          )
        )
      )
    }

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

  list(mapping = mapping, join_keys = join_keys)
}

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

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

#' Check if datasets can be merged in topological order
#'
#' Determines the topological order from join_keys, then checks that each dataset
#' can be joined with at least one of the previously accumulated datasets.
#'
#' @inheritParams merge_srv
#' @param join_keys (`join_keys`) The join keys object
#'
#' @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
}

#' `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
#' @export
#' @examples
#' 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.
#' @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
}

#' Merge module
#'
#' Example [`teal::module`] containing interactive inputs and displaying results of merge.
#'
#' @inheritParams teal::module
#' @param picks (`list` of `picks`)
#' @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 =
#'               ),
#'             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(id) {
            tags$div(
              class = "col-auto",
              tags$strong(tags$label(id)),
              teal.picks::picks_ui(
                id = ns(id),
                picks = picks[[id]]
              )
            )
          })
        ),
        shiny::div(
          shiny::tags$label("Join keys"),
          shiny::verbatimTextOutput(ns("join_keys")),
          shiny::tags$label("Mapped"),
          shiny::verbatimTextOutput(ns("mapped")),
          shiny::tags$label("Source code"),
          shiny::verbatimTextOutput(ns("src")),
          shiny::tags$label("Merge result"),
          shiny::tableOutput(ns("table_merged"))
        )
      )
    },
    server = function(id, data, picks) {
      shiny::moduleServer(id, function(input, output, session) {
        selectors <- picks_srv(id, picks = picks, data = data)

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

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

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

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

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

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

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

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

#' 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.
#' @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-dropdown-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(
          display = "none",
          position = "absolute",
          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
        )
      )
    )
  )
}

#' Create ui component for fixed ui picks without user selection
#' @param id (`character(1)`) shiny module's id
#' @param label (`shiny.tag`) Label displayed on the component
#' @keywords internal
#' @noRd
fixed_picks <- function(id, label) {
  ns <- shiny::NS(id)

  htmltools::tags$div(
    id = ns("fixed_picks_badge"),
    class = "fixed-picks",
    htmltools::tags$label(label),
    htmltools::tags$i(bsicons::bs_icon("lock-fill"))
  )
}

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

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

  invisible()
}

#' Generator function so that the functions can be generated programmatically.
#' @noRd
.check_pick_generator <- function(attr_name) {
  rlang::new_function(
    rlang::pairlist2(x = ),
    substitute(
      {
        checkmate::assert_class(x, classes = c("pick"))
        checkmate::assert_flag(attr(x, attr_name, exact = TRUE))
        isTRUE(attr(x, attr_name, exact = TRUE))
      },
      env = list(attr_name = attr_name)
    ),
    env = parent.frame()
  )
}

#' Helper functions for pick
#' @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.


#' @rdname helper_functions_pick
#' @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 <- .check_pick_generator("multiple")

#' @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 <- .check_pick_generator("fixed")

#' @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 <- .check_pick_generator("ordered")

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

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

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

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		#' @keywords internal
12		badge_dropdown <- function(id, label, content) {
13	3x	ns <- shiny::NS(id)
14	3x	htmltools::tagList(
15	3x	htmltools::singleton(htmltools::tags$head(
16	3x	htmltools::includeCSS(system.file("badge-dropdown", "style.css", package = "teal.picks")),
17	3x	htmltools::includeScript(system.file("badge-dropdown", "script.js", package = "teal.picks"))
18		)),
19	3x	htmltools::tags$div(
20	3x	class = "badge-dropdown-wrapper",
21	3x	htmltools::tags$span(
22	3x	id = ns("summary_badge"),
23	3x	class = "badge bg-primary rounded-pill badge-dropdown",
24	3x	style = "cursor: pointer;",
25	3x	tags$span(class = "badge-dropdown-label", label),
26	3x	tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")),
27	3x	onclick = sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container"))
28		),
29	3x	htmltools::tags$div(
30	3x	content,
31	3x	id = ns("inputs_container"),
32	3x	style = htmltools::css(
33	3x	display = "none",
34	3x	position = "absolute",
35	3x	background = "white",
36	3x	border = "1px solid #ccc",
37	3x	`border-radius` = "4px",
38	3x	`box-shadow` = "0 2px 10px rgba(0,0,0,0.1)",
39	3x	padding = "10px",
40	3x	`z-index` = "1050", # z-index set to 1000+50 to ensure that is above encoding panel on 1 column layout.
41	3x	`min-width` = "200px",
42	3x	transition = "opacity 0.2s ease",
43	3x	opacity = 0
44		)
45		)
46		)
47		)
48		}
49
50		#' Create ui component for fixed ui picks without user selection
51		#' @param id (`character(1)`) shiny module's id
52		#' @param label (`shiny.tag`) Label displayed on the component
53		#' @keywords internal
54		#' @noRd
55		fixed_picks <- function(id, label) {
56	1x	ns <- shiny::NS(id)
57
58	1x	htmltools::tags$div(
59	1x	id = ns("fixed_picks_badge"),
60	1x	class = "fixed-picks",
61	1x	htmltools::tags$label(label),
62	1x	htmltools::tags$i(bsicons::bs_icon("lock-fill"))
63		)
64		}

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	30x	checkmate::assert_string(operator)
214	30x	stopifnot(
215	30x	all(
216	30x	vapply(
217	30x	X = calls,
218	30x	FUN.VALUE = logical(1),
219	30x	FUN = function(x) is.language(x) \|\| is.logical(x)
220		)
221		)
222		)
223	30x	Reduce(
224	30x	x = calls,
225	30x	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		#' @keywords internal
237		.call_dplyr_select <- function(dataname, variables) {
238	31x	as.call(
239	31x	c(
240	31x	list(
241	31x	str2lang("dplyr::select"),
242	31x	str2lang(dataname)
243		),
244	31x	lapply(unname(variables), as.name)
245		)
246		)
247		}
248
249		#' `dplyr::filter` call
250		#'
251		#' Create a `dplyr::filter` call
252		#' @param x (`list`) containing `variables` and `values`
253		#' @keywords internal
254		.call_dplyr_filter <- function(x) {
255	10x	if (any(!names(x) %in% c("variables", "values"))) {
256	10x	predicates <- lapply(unname(x), .predicates)
257	10x	predicates <- Filter(length, predicates)
258		} else {
259	!	predicates <- .predicates(x)
260		}
261
262	10x	as.call(c(list(str2lang("dplyr::filter")), predicates))
263		}
264
265		.predicates <- function(x) {
266	10x	if (is.numeric(x$values) && .is_ranged(x$values)) {
267	1x	call_condition_range(varname = x$variables, range = x$values)
268	9x	} else if (inherits(x$values, "Date") && .is_ranged(x$values)) {
269	1x	call_condition_range_date(varname = x$variables, range = x$values)
270	8x	} else if (inherits(x$values, "POSIXct") && .is_ranged(x$values)) {
271	1x	call_condition_range_posixct(varname = x$variables, range = x$values)
272	7x	} else if (is.logical(x$values)) {
273	1x	call_condition_logical(varname = x$variables, choice = x$values)
274		} else if (
275	6x	checkmate::test_list(x$operators, types = "operator", min.len = 1) &&
276	6x	.is_operator_selected(x$operators, x$variables)
277		) {
278	!	if (length(x$operators) > 1) {
279	!	showNotification("Only a single complex operator can be used at a time when filtering by values.", type = "error")
280	!	return(NULL)
281		}
282	!	if (length(x$variables) > 1) {
283	!	showNotification(
284	!	"A complex operator filter cannot be combined with other variables. Filtering by the first variable only.",
285	!	type = "error"
286		)
287	!	return(NULL)
288		}
289	!	call_condition_operators(x$operators[[1]], choices = x$values)
290	6x	} else if (length(x$variables)) {
291	6x	if (is.factor(x$values)) {
292	!	x$values <- as.numeric(levels(x$values))[x$values]
293		}
294
295	6x	variable <- if (length(x$variables) > 1) {
296	1x	as.call(
297	1x	list(
298	1x	quote(apply),
299	1x	as.call(
300	1x	c(
301	1x	list(quote(data.frame)),
302	1x	unname(lapply(x$variables, as.name))
303		)
304		),
305	1x	1,
306	1x	quote(toString)
307		)
308		)
309		} else {
310	5x	x$variables
311		}
312	6x	call_condition_choice(varname = variable, choices = x$values)
313		}
314		}
315
316		.call_mutate_operators <- function(variables, operators_ix, dataname, operators) {
317	!	operators <- rlang::set_names(operators, vapply(operators, attr, which = "var_name", FUN.VALUE = character(1)))
318	!	select_new <- variables[operators_ix]
319	!	select_tmp <- unname(unlist(operators[select_new]))
320	!	select_call <- .call_dplyr_select(
321	!	dataname = dataname,
322	!	variables = unique(c(variables[!operators_ix], select_tmp))
323		)
324
325	!	select_call
326		}

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

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

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

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

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

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

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