teal.transform coverage - 81.12%

Files
Source

#' Include `CSS` files from `/inst/css/` package directory to application header
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`.
#' As a result, this method is individually redefined as required in each package.
#' Therefore, this function is not exported.
#'
#' @param pattern (`character`) pattern of files to be included.
#'
#' @return HTML code that includes `CSS` files.
#'
#' @keywords internal
#'
include_css_files <- function(pattern = "*") {
  css_files <- list.files(
    system.file("css", package = "teal.transform", mustWork = TRUE),
    pattern = pattern, full.names = TRUE
  )
  singleton(lapply(css_files, includeCSS))
}

#' 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 <- parsed[[1]]
    } 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, choices)
  } else {
    c_call <- do.call(
      "call",
      append(list("c"), choices)
    )
    # c_call needed because it needs to be vector call
    # instead of vector. SummarizedExperiment.subset
    # handles only vector calls
    call("%in%", 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, range[1]),
    call("<=", varname, 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(
    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])))
  )
}

#' Get call to subset and select array
#'
#' @param dataname (`character(1)` or `name`).
#' @param row (optional `name` or `call` or `logical` or `integer` or `character`)
#' name of the `row` or condition.
#' @param column (optional `name` or `call` or `logical`, `integer` or `character`)
#' name of the `column` or condition.
#' @param aisle (optional `name` or `call` or `logical` or `integer` or `character`)
#' name of the `row` or condition.
#'
#' @return [Extract()] `call` for 3-dimensional array in `x[i, j, k]` notation.
#'
#' @keywords internal
#'
call_extract_array <- function(dataname = ".", row = NULL, column = NULL, aisle = NULL) {
  checkmate::assert(
    checkmate::check_string(dataname),
    checkmate::check_class(dataname, "call"),
    checkmate::check_class(dataname, "name")
  )
  stopifnot(is.null(row) || is.call(row) || is.character(row) || is.logical(row) || is.integer(row) || is.name(row))
  stopifnot(is.null(column) || is.call(column) || is.vector(column) || is.name(column))
  stopifnot(is.null(aisle) || is.call(aisle) || is.vector(aisle) || is.name(aisle))

  if (is.language(dataname)) {
    dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n")
  }

  row <- if (is.null(row)) {
    ""
  } else {
    paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n")
  }
  column <- if (is.null(column)) {
    ""
  } else {
    paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n")
  }
  aisle <- if (is.null(aisle)) {
    ""
  } else {
    paste(trimws(deparse(aisle, width.cutoff = 500L)), collapse = "\n")
  }

  parse(
    text = sprintf("%s[%s, %s, %s]", dataname, row, column, aisle),
    keep.source = FALSE
  )[[1]]
}

#' Get call to subset and select matrix
#'
#' @param dataname (`character(1)` or `name`).
#' @param row (optional `name` or `call` or `logical` or `integer` or `character`)
#' name of the `row` or condition.
#' @param column (optional `name` or `call` or `logical` or `integer` or `character`)
#' name of the `column` or condition.
#'
#' @return [Extract()] `call` for matrix in `x[i, j]` notation.
#'
#' @keywords internal
#'
call_extract_matrix <- function(dataname = ".", row = NULL, column = NULL) {
  checkmate::assert(
    checkmate::check_string(dataname),
    checkmate::check_class(dataname, "call"),
    checkmate::check_class(dataname, "name")
  )
  stopifnot(is.null(row) || is.call(row) || is.character(row) || is.logical(row) || is.integer(row) || is.name(row))
  stopifnot(is.null(column) || is.call(column) || is.vector(column) || is.name(column))

  if (is.language(dataname)) {
    dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n")
  }

  row <- if (is.null(row)) {
    ""
  } else {
    paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n")
  }
  column <- if (is.null(column)) {
    ""
  } else {
    paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n")
  }

  parse(
    text = sprintf("%s[%s, %s]", dataname, row, column),
    keep.source = FALSE
  )[[1]]
}


#' Compose extract call with `$` operator
#'
#' @param dataname (`character(1)` or `name`) name of the object.
#' @param varname (`character(1)` or `name`) name of the slot in data.
#' @param dollar (`logical(1)`) whether returned call should use `$` or `[[` operator.
#'
#' @return [Extract()] `call` in `$` or `[[` notation (depending on parameters).
#'
#' @keywords internal
#'
call_extract_list <- function(dataname, varname, dollar = TRUE) {
  checkmate::assert_flag(dollar)
  checkmate::assert(
    checkmate::check_string(varname),
    checkmate::check_class(varname, "name"),
    checkmate::assert(
      combine = "and",
      checkmate::check_class(varname, "call"),
      checkmate::check_false(dollar)
    )
  )

  dataname <- call_check_parse_varname(dataname)

  if (dollar) {
    call("$", dataname, varname)
  } else {
    call("[[", dataname, varname)
  }
}

#' Create a call using a function in a given namespace
#'
#' The dot arguments in `...` need to be quoted because they will be evaluated otherwise.
#'
#' @param name `character` function name, possibly using namespace colon `::`, also
#' works with `:::` (sometimes needed, but strongly discouraged).
#' @param ... arguments to pass to function with name `name`.
#' @param unlist_args `list` extra arguments passed in a single list,
#' avoids the use of `do.call` with this function.
#'
#' @return `call`.
#'
#' @keywords internal
#'
call_with_colon <- function(name, ..., unlist_args = list()) {
  checkmate::assert_string(name)
  checkmate::assert_list(unlist_args)
  as.call(c(
    parse(text = name, keep.source = FALSE)[[1]],
    c(list(...), unlist_args)
  ))
}


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

#' Check data extract specification
#'
#' @param data_extract_spec (`list`) of `data_extract_spec`.
#'
#' @return Raises an error when check fails, otherwise, it returns the `data_extract_spec`
#' parameter, invisibly and unchanged.
#'
#' @keywords internal
#'
check_data_extract_spec <- function(data_extract_spec) {
  checkmate::assert_list(data_extract_spec, types = "data_extract_spec", null.ok = TRUE)
}

#' Generate id for dataset
#'
#' @param dataname (`character(1)`) the name of the dataset.
#'
#' @return `character(1)`.
#'
#' @keywords internal
#'
id_for_dataset <- function(dataname) {
  paste0("dataset_", dataname, "_singleextract")
}

#' Creates a panel that displays (with filter and column selection)
#' conditionally on `input[ns("dataset")] == dataname`
#'
#' @param ns (`function`) the shiny namespace function.
#' @param single_data_extract_spec (`data_extract_spec`) the specification
#' for extraction of data during the application initialization.
#'
#' Generated by [data_extract_spec()].
#'
#' @return `shiny.tag` with the HTML code for the panel.
#'
#' @keywords internal
#'
cond_data_extract_single_ui <- function(ns, single_data_extract_spec) {
  dataname <- single_data_extract_spec$dataname
  conditionalPanel(
    condition = paste0("input['", ns("dataset"), "'] == '", dataname, "'"),
    data_extract_single_ui(
      id = ns(id_for_dataset(dataname)),
      single_data_extract_spec = single_data_extract_spec
    )
  )
}

#' `teal` data extraction module user-interface
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' @details
#' There are three inputs that will be rendered
#'
#' 1. Dataset select Optional. If more than one [data_extract_spec] is handed over
#' to the function, a shiny [shiny::selectInput] will be rendered. Else just the name
#' of the dataset is given.
#' 2. Filter Panel Optional. If the [data_extract_spec] contains a
#' filter element a shiny [shiny::selectInput] will be rendered with the options to
#' filter the dataset.
#' 3. Select panel A shiny [shiny::selectInput] to select columns from the dataset to
#' go into the analysis.
#'
#' The output can be analyzed using `data_extract_srv(...)`.
#'
#' This functionality should be used in the encoding panel of your `teal` app.
#' It will allow app-developers to specify a [data_extract_spec()] object.
#' This object should be used to `teal` module variables being filtered data
#' from CDISC datasets.
#'
#' You can use this function in the same way as any
#' [`shiny module`](https://shiny.rstudio.com/articles/modules.html) UI.
#' The corresponding server module can be found in [data_extract_srv()].
#'
#' @param id (`character`) shiny input unique identifier.
#' @param label (`character`) Label above the data extract input.
#' @param data_extract_spec (`list` of `data_extract_spec`)
#' This is the outcome of listing [data_extract_spec()] constructor calls.
#' @param is_single_dataset (`logical`) `FALSE` to display the dataset widget.
#'
#' @return Shiny [`shiny::selectInput`]`s` that allow to define how to extract data from
#' a specific dataset. The input elements will be returned inside a [shiny::div] container.
#'
#' @examples
#' library(shiny)
#' library(teal.widgets)
#'
#' adtte_filters <- filter_spec(
#'   vars = c("PARAMCD", "CNSR"),
#'   sep = "-",
#'   choices = c("OS-1" = "OS-1", "OS-0" = "OS-0", "PFS-1" = "PFS-1"),
#'   selected = "OS-1",
#'   multiple = FALSE,
#'   label = "Choose endpoint and Censor"
#' )
#'
#' response_spec <- data_extract_spec(
#'   dataname = "ADTTE",
#'   filter = adtte_filters,
#'   select = select_spec(
#'     choices = c("AVAL", "BMRKR1", "AGE"),
#'     selected = c("AVAL", "BMRKR1"),
#'     multiple = TRUE,
#'     fixed = FALSE,
#'     label = "Column"
#'   )
#' )
#' # Call to use inside your teal module UI function
#' standard_layout(
#'   output = tableOutput("table"),
#'   encoding = div(
#'     data_extract_ui(
#'       id = "regressor",
#'       label = "Regressor Variable",
#'       data_extract_spec = response_spec
#'     )
#'   )
#' )
#'
#' @export
#'
data_extract_ui <- function(id, label, data_extract_spec, is_single_dataset = FALSE) {
  ns <- NS(id)

  if (inherits(data_extract_spec, "data_extract_spec")) {
    data_extract_spec <- list(data_extract_spec)
  }
  check_data_extract_spec(data_extract_spec)

  if (is.null(data_extract_spec)) {
    return(helpText(sprintf("Data extraction with label '%s' is NULL. Please contact the app author.", label)))
  }
  stopifnot(
    `more than one dataset in data_extract_spec but is_single_dataset parameter is set to TRUE` =
      !is_single_dataset || length(data_extract_spec) == 1
  )

  dataset_names <- vapply(
    data_extract_spec,
    function(x) x$dataname,
    character(1),
    USE.NAMES = FALSE
  )

  stopifnot(`list contains data_extract_spec objects with the same dataset` = all(!duplicated(dataset_names)))

  dataset_input <- if (is_single_dataset) {
    NULL
  } else {
    if (length(dataset_names) == 1) {
      if ((is.null(data_extract_spec[[1]]$filter)) &&
        (
          !is.null(data_extract_spec[[1]]$select$fixed) &&
            data_extract_spec[[1]]$select$fixed == TRUE
        )) {
        NULL
      } else {
        helpText("Dataset:", tags$code(dataset_names))
      }
    } else {
      teal.widgets::optionalSelectInput(
        inputId = ns("dataset"),
        label = "Dataset",
        choices = dataset_names,
        selected = dataset_names[1],
        multiple = FALSE
      )
    }
  }
  tagList(
    include_css_files(pattern = "data_extract"),
    div(
      class = "data-extract",
      tags$label(label),
      dataset_input,
      if (length(dataset_names) == 1) {
        data_extract_single_ui(
          id = ns(id_for_dataset(dataset_names)),
          single_data_extract_spec = data_extract_spec[[1]]
        )
      } else {
        do.call(
          div,
          unname(lapply(
            data_extract_spec,
            function(x) {
              cond_data_extract_single_ui(ns, x)
            }
          ))
        )
      }
    )
  )
}

#' Function to check data_extract_specs
#'
#' Checks if `dataname` argument exists as a dataset.
#' Checks if selected or filter columns exist within the datasets. Throws a `shiny`
#' validation error if the above requirements are not met.
#'
#' @param datasets (`FilteredData`) the object created using the `teal` API.
#' @param data_extract (`list`) the output of the `data_extract` module.
#'
#' @return `NULL`.
#'
#' @keywords internal
#'
check_data_extract_spec_react <- function(datasets, data_extract) {
  if (!all(unlist(lapply(data_extract, `[[`, "dataname")) %in% datasets$datanames())) {
    shiny::validate(
      "Error in data_extract_spec setup:\
        Data extract spec contains datasets that were not handed over to the teal app."
    )
  }

  column_return <- unlist(lapply(
    data_extract,
    function(data_extract_spec) {
      columns_filter <- if (is.null(data_extract_spec$filter)) {
        NULL
      } else {
        unique(unlist(lapply(
          data_extract_spec$filter,
          function(x) {
            if (inherits(x, "filter_spec")) {
              x$vars_choices
            } else {
              stop("Unsupported object class")
            }
          }
        )))
      }

      columns_ds <- unique(c(
        data_extract_spec$select$choices,
        columns_filter
      ))

      if (!all(columns_ds %in% names(datasets$get_data(data_extract_spec$dataname, filtered = FALSE)))) {
        non_columns <- columns_ds[!columns_ds %in% names(
          datasets$get_data(data_extract_spec$dataname, filtered = FALSE)
        )]
        paste0(
          "Error in data_extract_spec setup: ",
          "Column '",
          non_columns,
          "' is not inside dataset '",
          data_extract_spec$dataname, "'."
        )
      }
    }
  ))

  if (!is.null(column_return)) shiny::validate(unlist(column_return))
  NULL
}

#' Extraction of the selector(s) details
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Extracting details of the selection(s) in [data_extract_ui] elements.
#'
#' @inheritParams shiny::moduleServer
#' @param datasets (`FilteredData` or `list` of `reactive` or non-`reactive` `data.frame`)
#' object containing data either in the form of `FilteredData` or as a list of `data.frame`.
#' When passing a list of non-reactive `data.frame` objects, they are converted to reactive `data.frame`s internally.
#' When passing a list of reactive or non-reactive `data.frame` objects, the argument `join_keys` is required also.
#' @param data_extract_spec (`data_extract_spec` or a list of `data_extract_spec`)
#' A list of data filter and select information constructed by [data_extract_spec].
#' @param ... An additional argument `join_keys` is required when `datasets` is a list of `data.frame`.
#' It shall contain the keys per dataset in `datasets`.
#'
#' @return A reactive `list` containing following fields:
#'
#' * `filters`: A list with the information on the filters that are applied to the data set.
#' * `select`: The variables that are selected from the dataset.
#' * `always_selected`: The column names from the data set that should always be selected.
#' * `reshape`: Whether reshape long to wide should be applied or not.
#' * `dataname`: The name of the data set.
#' * `internal_id`: The `id` of the corresponding shiny input element.
#' * `keys`: The names of the columns that can be used to merge the data set.
#' * `iv`: A `shinyvalidate::InputValidator` containing `validator` for this `data_extract`.
#'
#' @references [data_extract_srv]
#'
#' @examples
#' library(shiny)
#' library(shinyvalidate)
#' library(teal.data)
#' library(teal.widgets)
#'
#' # Sample ADSL dataset
#' ADSL <- data.frame(
#'   STUDYID = "A",
#'   USUBJID = LETTERS[1:10],
#'   SEX = rep(c("F", "M"), 5),
#'   AGE = rpois(10, 30),
#'   BMRKR1 = rlnorm(10)
#' )
#'
#' # Specification for data extraction
#' adsl_extract <- data_extract_spec(
#'   dataname = "ADSL",
#'   filter = filter_spec(vars = "SEX", choices = c("F", "M"), selected = "F"),
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = variable_choices(ADSL, c("AGE", "BMRKR1")),
#'     selected = "AGE",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#'
#' # Using reactive list of data.frames
#' data_list <- list(ADSL = reactive(ADSL))
#'
#' join_keys <- join_keys(join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")))
#'
#' # App: data extraction with validation
#' ui <- fluidPage(
#'   standard_layout(
#'     output = verbatimTextOutput("out1"),
#'     encoding = tagList(
#'       data_extract_ui(
#'         id = "adsl_var",
#'         label = "ADSL selection",
#'         data_extract_spec = adsl_extract
#'       )
#'     )
#'   )
#' )
#' server <- function(input, output, session) {
#'   adsl_reactive_input <- data_extract_srv(
#'     id = "adsl_var",
#'     datasets = data_list,
#'     data_extract_spec = adsl_extract,
#'     join_keys = join_keys,
#'     select_validation_rule = sv_required("Please select a variable.")
#'   )
#'
#'   iv_r <- reactive({
#'     iv <- InputValidator$new()
#'     iv$add_validator(adsl_reactive_input()$iv)
#'     iv$enable()
#'     iv
#'   })
#'
#'   output$out1 <- renderPrint({
#'     if (iv_r()$is_valid()) {
#'       cat(format_data_extract(adsl_reactive_input()))
#'     } else {
#'       "Please fix errors in your selection"
#'     }
#'   })
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' # App: simplified data extraction
#' ui <- fluidPage(
#'   standard_layout(
#'     output = verbatimTextOutput("out1"),
#'     encoding = tagList(
#'       data_extract_ui(
#'         id = "adsl_var",
#'         label = "ADSL selection",
#'         data_extract_spec = adsl_extract
#'       )
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   adsl_reactive_input <- data_extract_srv(
#'     id = "adsl_var",
#'     datasets = data_list,
#'     data_extract_spec = adsl_extract
#'   )
#'
#'   output$out1 <- renderPrint(adsl_reactive_input())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @export
#'
data_extract_srv <- function(id, datasets, data_extract_spec, ...) {
  checkmate::assert_multi_class(datasets, c("FilteredData", "list"))
  checkmate::assert(
    checkmate::check_class(data_extract_spec, "data_extract_spec"),
    checkmate::check_list(data_extract_spec, "data_extract_spec")
  )
  UseMethod("data_extract_srv", datasets)
}

#' @rdname data_extract_srv
#' @export
#'
data_extract_srv.FilteredData <- function(id, datasets, data_extract_spec, ...) {
  checkmate::assert_class(datasets, "FilteredData")
  moduleServer(
    id,
    function(input, output, session) {
      logger::log_trace(
        "data_extract_srv.FilteredData initialized with datasets: { paste(datasets$datanames(), collapse = ', ') }."
      )

      data_list <- sapply(X = datasets$datanames(), simplify = FALSE, FUN = function(x) {
        reactive(datasets$get_data(dataname = x, filtered = TRUE))
      })

      join_keys <- datasets$get_join_keys()

      filter_and_select_reactive <- data_extract_srv(
        id = NULL,
        datasets = data_list,
        data_extract_spec = data_extract_spec,
        join_keys = join_keys
      )
      filter_and_select_reactive
    }
  )
}

#' @rdname data_extract_srv
#'
#' @param join_keys (`join_keys` or `NULL`) of keys per dataset in `datasets`.
#' @param select_validation_rule (`NULL` or `function`)
#' Should there be any `shinyvalidate` input validation of the select parts of the `data_extract_ui`.
#'
#' You can use a validation function directly (i.e. `select_validation_rule = shinyvalidate::sv_required()`)
#' or for more fine-grained control use a function:
#'
#' `select_validation_rule = ~ if (length(.) > 2) "Error"`.
#'
#' If `NULL` then no validation will be added. See example for more details.
#' @param filter_validation_rule (`NULL` or `function`) Same as
#' `select_validation_rule` but for the filter (values) part of the `data_extract_ui`.
#' @param dataset_validation_rule (`NULL` or `function`) Same as
#' `select_validation_rule` but for the choose dataset part of the `data_extract_ui`
#' @export
#'
data_extract_srv.list <- function(id,
                                  datasets,
                                  data_extract_spec,
                                  join_keys = NULL,
                                  select_validation_rule = NULL,
                                  filter_validation_rule = NULL,
                                  dataset_validation_rule = if (
                                    is.null(select_validation_rule) &&
                                      is.null(filter_validation_rule)
                                  ) {
                                    NULL
                                  } else {
                                    shinyvalidate::sv_required("Please select a dataset")
                                  },
                                  ...) {
  checkmate::assert_list(datasets, types = c("reactive", "data.frame"), names = "named")
  checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)
  checkmate::assert_multi_class(select_validation_rule, classes = c("function", "formula"), null.ok = TRUE)
  checkmate::assert_multi_class(filter_validation_rule, classes = c("function", "formula"), null.ok = TRUE)
  checkmate::assert_multi_class(dataset_validation_rule, classes = c("function", "formula"), null.ok = TRUE)

  moduleServer(
    id,
    function(input, output, session) {
      logger::log_trace(
        "data_extract_srv.list initialized with datasets: { paste(names(datasets), collapse = ', ') }."
      )

      # get keys out of join_keys
      if (length(join_keys)) {
        keys <- sapply(names(datasets), simplify = FALSE, function(x) join_keys[x, x])
      } else {
        keys <- sapply(names(datasets), simplify = FALSE, function(x) character(0))
      }

      # convert to list of reactives
      datasets <- sapply(X = datasets, simplify = FALSE, FUN = function(x) {
        if (is.reactive(x)) x else reactive(x)
      })

      if (inherits(data_extract_spec, "data_extract_spec")) {
        data_extract_spec <- list(data_extract_spec)
      }

      for (idx in seq_along(data_extract_spec)) {
        if (inherits(data_extract_spec[[idx]]$filter, "filter_spec")) {
          data_extract_spec[[idx]]$filter <- list(data_extract_spec[[idx]]$filter)
        }
      }

      if (is.null(data_extract_spec)) {
        return(reactive(NULL))
      }
      check_data_extract_spec(data_extract_spec = data_extract_spec)

      # Each dataset needs its own shinyvalidate to make sure only the
      # currently visible d-e-s's validation is used
      iv <- lapply(data_extract_spec, function(x) {
        iv_dataset <- shinyvalidate::InputValidator$new()
        if (!is.null(dataset_validation_rule) && length(data_extract_spec) > 1) {
          iv_dataset$add_rule("dataset", dataset_validation_rule)
        }
        iv_dataset
      })
      names(iv) <- lapply(data_extract_spec, `[[`, "dataname")

      # also need a final iv for the case where no dataset is selected
      iv[["blank_dataset_case"]] <- shinyvalidate::InputValidator$new()
      if (!is.null(dataset_validation_rule) && length(data_extract_spec) > 1) {
        iv[["blank_dataset_case"]]$add_rule("dataset", dataset_validation_rule)
      }

      filter_and_select <- lapply(data_extract_spec, function(x) {
        data_extract_single_srv(
          id = id_for_dataset(x$dataname),
          datasets = datasets,
          single_data_extract_spec = x
        )

        data_extract_read_srv(
          id = id_for_dataset(x$dataname),
          datasets = datasets,
          single_data_extract_spec = x,
          iv = iv[[x$dataname]],
          select_validation_rule = select_validation_rule,
          filter_validation_rule = filter_validation_rule
        )
      })
      names(filter_and_select) <- sapply(data_extract_spec, function(x) x$dataname)

      dataname <- reactive({
        # For fixed data sets, ignore input_value
        if (is.null(input$dataset) && length(data_extract_spec) < 2) {
          data_extract_spec[[1]]$dataname
          # For data set selectors, return NULL if NULL
        } else {
          input$dataset
        }
      })

      filter_and_select_reactive <- reactive({
        if (is.null(dataname())) {
          list(iv = iv[["blank_dataset_case"]])
        } else {
          append(
            filter_and_select[[dataname()]](),
            list(
              dataname = dataname(),
              internal_id = gsub("^.*-(.+)$", "\\1", session$ns(NULL)), # parent module id
              keys = keys[[dataname()]]
            )
          )
        }
      })
      filter_and_select_reactive
    }
  )
}

#' Creates a named list of `data_extract_srv` output
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' `data_extract_multiple_srv` loops over the list of `data_extract` given and
#' runs `data_extract_srv` for each one returning a list of reactive objects.
#'
#' @inheritParams data_extract_srv
#' @param data_extract (named `list` of `data_extract_spec` objects) the list `data_extract_spec` objects.
#' The names of the elements in the list need to correspond to the `ids` passed to `data_extract_ui`.
#'
#' See example for details.
#'
#' @return reactive named `list` containing outputs from [data_extract_srv()].
#' Output list names are the same as `data_extract` input argument.
#'
#' @examples
#' library(shiny)
#' library(shinyvalidate)
#' library(shinyjs)
#' library(teal.widgets)
#'
#' iris_select <- data_extract_spec(
#'   dataname = "iris",
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = variable_choices(iris, colnames(iris)),
#'     selected = "Sepal.Length",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#'
#' iris_filter <- data_extract_spec(
#'   dataname = "iris",
#'   filter = filter_spec(
#'     vars = "Species",
#'     choices = c("setosa", "versicolor", "virginica"),
#'     selected = "setosa",
#'     multiple = TRUE
#'   )
#' )
#'
#' data_list <- list(iris = reactive(iris))
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   standard_layout(
#'     output = verbatimTextOutput("out1"),
#'     encoding = tagList(
#'       data_extract_ui(
#'         id = "x_var",
#'         label = "Please select an X column",
#'         data_extract_spec = iris_select
#'       ),
#'       data_extract_ui(
#'         id = "species_var",
#'         label = "Please select 2 Species",
#'         data_extract_spec = iris_filter
#'       )
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   exactly_2_validation <- function(msg) {
#'     ~ if (length(.) != 2) msg
#'   }
#'
#'
#'   selector_list <- data_extract_multiple_srv(
#'     list(x_var = iris_select, species_var = iris_filter),
#'     datasets = data_list,
#'     select_validation_rule = list(
#'       x_var = sv_required("Please select an X column")
#'     ),
#'     filter_validation_rule = list(
#'       species_var = compose_rules(
#'         sv_required("Exactly 2 Species must be chosen"),
#'         exactly_2_validation("Exactly 2 Species must be chosen")
#'       )
#'     )
#'   )
#'   iv_r <- reactive({
#'     iv <- InputValidator$new()
#'     compose_and_enable_validators(
#'       iv,
#'       selector_list,
#'       validator_names = NULL
#'     )
#'   })
#'
#'   output$out1 <- renderPrint({
#'     if (iv_r()$is_valid()) {
#'       ans <- lapply(selector_list(), function(x) {
#'         cat(format_data_extract(x()), "\n\n")
#'       })
#'     } else {
#'       "Please fix errors in your selection"
#'     }
#'   })
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
data_extract_multiple_srv <- function(data_extract, datasets, ...) {
  checkmate::assert_list(data_extract, names = "named")
  checkmate::assert_multi_class(datasets, c("reactive", "FilteredData", "list"))
  lapply(data_extract, function(x) {
    if (is.list(x) && !inherits(x, "data_extract_spec")) {
      checkmate::assert_list(x, "data_extract_spec")
    }
  })
  UseMethod("data_extract_multiple_srv", datasets)
}

#' @rdname data_extract_multiple_srv
#' @export
#'
data_extract_multiple_srv.reactive <- function(data_extract, datasets, ...) {
  # convert reactive containing teal_data to list of reactives with one dataset each
  datasets_new <- convert_teal_data(datasets)
  data_extract_multiple_srv.list(data_extract, datasets_new, ...)
}

#' @rdname data_extract_multiple_srv
#' @export
#'
data_extract_multiple_srv.FilteredData <- function(data_extract, datasets, ...) {
  checkmate::assert_class(datasets, classes = "FilteredData")
  logger::log_trace(
    "data_extract_multiple_srv.filteredData initialized with dataset: { paste(datasets$datanames(), collapse = ', ') }."
  )

  data_list <- sapply(X = datasets$datanames(), simplify = FALSE, FUN = function(x) {
    reactive(datasets$get_data(dataname = x, filtered = TRUE))
  })

  join_keys <- datasets$get_join_keys()
  data_extract_multiple_srv(data_extract = data_extract, datasets = data_list, join_keys = join_keys)
}

#' @rdname data_extract_multiple_srv
#'
#' @param join_keys (`join_keys` or `NULL`) of join keys per dataset in `datasets`.
#' @param select_validation_rule (`NULL` or `function` or `named list` of `function`)
#' Should there be any `shinyvalidate` input validation of the select parts of the `data_extract_ui`.
#' If all `data_extract` require the same validation function then this can be used directly
#' (i.e. `select_validation_rule = shinyvalidate::sv_required()`).
#'
#' For more fine-grained control use a list:
#'
#' `select_validation_rule = list(extract_1 = sv_required(), extract2 = ~ if (length(.) > 2) "Error")`
#'
#' If `NULL` then no validation will be added.
#'
#' See example for more details.
#' @param filter_validation_rule (`NULL` or `function` or `named list` of `function`) Same as
#' `select_validation_rule` but for the filter (values) part of the `data_extract_ui`.
#' @param dataset_validation_rule (`NULL` or `function` or `named list` of `function`) Same as
#' `select_validation_rule` but for the choose dataset part of the `data_extract_ui`
#'
#' @export
#'
data_extract_multiple_srv.list <- function(data_extract,
                                           datasets,
                                           join_keys = NULL,
                                           select_validation_rule = NULL,
                                           filter_validation_rule = NULL,
                                           dataset_validation_rule = if (
                                             is.null(select_validation_rule) &&
                                               is.null(filter_validation_rule)
                                           ) {
                                             NULL
                                           } else {
                                             shinyvalidate::sv_required("Please select a dataset")
                                           },
                                           ...) {
  checkmate::assert_list(datasets, types = c("reactive", "data.frame"), names = "named")
  checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)
  checkmate::assert(
    checkmate::check_multi_class(select_validation_rule, classes = c("function", "formula"), null.ok = TRUE),
    checkmate::check_list(select_validation_rule, types = c("function", "formula", "NULL"), null.ok = TRUE)
  )
  checkmate::assert(
    checkmate::check_multi_class(filter_validation_rule, classes = c("function", "formula"), null.ok = TRUE),
    checkmate::check_list(filter_validation_rule, types = c("function", "formula", "NULL"), null.ok = TRUE)
  )
  checkmate::assert(
    checkmate::check_multi_class(dataset_validation_rule, classes = c("function", "formula"), null.ok = TRUE),
    checkmate::check_list(dataset_validation_rule, types = c("function", "formula", "NULL"), null.ok = TRUE)
  )

  logger::log_trace(
    "data_extract_multiple_srv.list initialized with dataset: { paste(names(datasets), collapse = ', ') }."
  )

  data_extract <- Filter(Negate(is.null), data_extract)

  if (is.function(select_validation_rule)) {
    select_validation_rule <- sapply(
      names(data_extract),
      simplify = FALSE,
      USE.NAMES = TRUE,
      function(x) select_validation_rule
    )
  }

  if (is.function(dataset_validation_rule)) {
    dataset_validation_rule <- sapply(
      names(data_extract),
      simplify = FALSE,
      USE.NAMES = TRUE,
      function(x) dataset_validation_rule
    )
  }

  reactive({
    sapply(
      X = names(data_extract),
      simplify = FALSE,
      USE.NAMES = TRUE,
      function(x) {
        data_extract_srv(
          id = x,
          data_extract_spec = data_extract[[x]],
          datasets = datasets,
          join_keys = join_keys,
          select_validation_rule = select_validation_rule[[x]],
          filter_validation_rule = filter_validation_rule[[x]],
          dataset_validation_rule = dataset_validation_rule[[x]]
        )
      }
    )
  })
}

# Queue ====

#' R6 Class - A First-In-First-Out Abstract Data Type
#' @docType class
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Abstract data type that stores and returns any number of elements.
#'
#' @details
#' A `Queue` object stores all elements in a single vector,
#' thus all data types can be stored, but silent coercion may occur.
#'
#' Elements are returned in the same order that they were added.
#'
#' @name Queue
#' @keywords internal
#'
Queue <- R6::R6Class( # nolint: object_name_linter.
  classname = "Queue",
  # public methods ----
  public = list(
    #' @description
    #' Adds element(s) to `Queue`.
    #'
    #' @param new_elements vector of elements to add.
    #'
    #' @return `self`, invisibly.
    #'
    push = function(new_elements) {
      for (i in seq_along(new_elements)) {
        # new_elements[i] does not discard names if it's a named list
        private$array <- append(private$array, new_elements[i])
      }

      invisible(self)
    },
    #' @description
    #' Returns all contents of the `Queue` object.
    #'
    #' @return Single vector containing all `Queue` contents.
    #'
    get = function() {
      private$array
    },
    #' @description
    #' Returns the first (oldest) element of the `Queue` and removes it.
    #'
    #' @return vector of length 1 containing the first element of `Queue`
    #' or `NULL` if `Queue` is empty.
    #'
    pop = function() {
      returned_element <- self$get()[1L]
      private$array <- private$array[-1L]
      returned_element
    },
    #' @description
    #' Removes the oldest occurrence of specified element(s) from `Queue`.
    #' Relies on implicit type conversions of R identify elements to remove.
    #'
    #' @param elements vector of elements to remove from `Queue`.
    #'
    #' @return `self`, invisibly.
    #'
    remove = function(elements) {
      for (el in elements) {
        ind <- Position(function(x) identical(x, el), private$array)
        if (!is.na(ind)) private$array <- private$array[-ind]
      }
      invisible(self)
    },
    #' @description
    #' Removes all elements from `Queue`.
    #'
    #' @return `self`, invisibly.
    #'
    empty = function() {
      private$array <- c()
      invisible(self)
    },
    #' @description
    #' Returns the number of elements in `Queue`.
    #'
    #' @return `integer(1)`.
    #'
    size = function() {
      length(self$get())
    },
    #' @description
    #' Prints this `Queue`.
    #'
    #' @param ... Additional arguments to this method, ignored.
    #'
    #' @return `self`, invisibly.
    print = function(...) {
      cat(
        sprintf(
          "%s\nSize: %i\nElements:\n%s\n",
          strsplit(format(self), "\n")[[1]][1],
          self$size(),
          paste(self$get(), collapse = " ")
        )
      )
      invisible(self)
    }
  ),

  # private members ----
  private = list(
    array = c()
  ),
  lock_class = TRUE
)

no_select_keyword <- "-- no selection --"

#' Choices selected
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Construct a single list containing available choices, the default selected value, and
#' additional settings such as to order the choices with the selected elements appearing first
#' or whether to block the user from making selections.
#'
#' Can be used in UI input elements such as [teal.widgets::optionalSelectInput()].
#'
#' @details
#' Please note that the order of selected will always follow the order of choices. The `keep_order`
#' argument is set to false which will run the following code inside:
#'
#' ```
#' choices <- c(selected, setdiff(choices, selected))
#' ```
#'
#' In case you want to keep your specific order of choices, set `keep_order` to `TRUE`.
#'
#' @param choices (`character`) vector of possible choices or `delayed_data` object.
#'
#' See [variable_choices()] and [value_choices()].
#' @param selected (`character`) vector of preselected options, (`all_choices`) object
#' or (`delayed_data`) object.
#'
#' If `delayed_data` object then `choices` must also be `delayed_data` object.
#' If not supplied it will default to the first element of `choices` if
#' `choices` is a vector, or `NULL` if `choices` is a `delayed_data` object.
#' @param keep_order (`logical`) In case of `FALSE` the selected variables will
#' be on top of the drop-down field.
#' @param fixed (optional `logical`) Whether to block user to select choices.
#'
#' @return `choices_selected` returns list of `choices_selected`, encapsulating the specified
#' `choices`, `selected`, `keep_order` and `fixed`.
#'
#' @examples
#' library(shiny)
#' library(teal.widgets)
#'
#' # all_choices example - semantically the same objects
#' choices_selected(choices = letters, selected = all_choices())
#' choices_selected(choices = letters, selected = letters)
#'
#' choices_selected(
#'   choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])),
#'   selected = "C"
#' )
#'
#' ADSL <- teal.transform::rADSL
#' choices_selected(variable_choices(ADSL), "SEX")
#'
#' # How to select nothing
#' # use an empty character
#' choices_selected(
#'   choices = c("", "A", "B", "C"),
#'   selected = ""
#' )
#'
#' # How to allow the user to select nothing
#' # use an empty character
#' choices_selected(
#'   choices = c("A", "", "B", "C"),
#'   selected = "A"
#' )
#'
#'
#' # How to make Nothing the Xth choice
#' # just use keep_order
#' choices_selected(
#'   choices = c("A", "", "B", "C"),
#'   selected = "A",
#'   keep_order = TRUE
#' )
#'
#'
#' # How to give labels to selections
#' # by adding names - choices will be replaced by "name" in UI, not in code
#' choices_selected(
#'   choices = c("name for A" = "A", "Name for nothing" = "", "name for b" = "B", "name for C" = "C"),
#'   selected = "A"
#' )
#'
#' # by using choices_labeled
#' # labels will be shown behind the choice
#' choices_selected(
#'   choices = choices_labeled(
#'     c("A", "", "B", "C"),
#'     c("name for A", "nothing", "name for B", "name for C")
#'   ),
#'   selected = "A"
#' )
#'
#' # Passing a `delayed_data` object to `selected`
#' choices_selected(
#'   choices = variable_choices("ADSL"),
#'   selected = variable_choices("ADSL", subset = c("STUDYID"))
#' )
#'
#' # functional form (subsetting for factor variables only) of choices_selected
#' # with delayed data loading
#' choices_selected(variable_choices("ADSL", subset = function(data) {
#'   idx <- vapply(data, is.factor, logical(1))
#'   names(data)[idx]
#' }))
#'
#' cs <- choices_selected(
#'   choices = c("A", "B", "C"),
#'   selected = "A"
#' )
#'
#' ui <- fluidPage(
#'   optionalSelectInput(
#'     inputId = "id",
#'     choices = cs$choices,
#'     selected = cs$selected
#'   )
#' )
#'
#' server <- function(input, output, session) {}
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
choices_selected <- function(choices,
                             selected = if (inherits(choices, "delayed_data")) NULL else choices[1],
                             keep_order = FALSE,
                             fixed = FALSE) {
  checkmate::assert(
    checkmate::check_atomic(choices),
    checkmate::check_class(choices, "delayed_data")
  )
  checkmate::assert(
    checkmate::check_atomic(selected),
    checkmate::check_multi_class(selected, c("delayed_data", "all_choices"))
  )
  checkmate::assert_flag(keep_order)
  checkmate::assert_flag(fixed)

  if (inherits(selected, "all_choices")) selected <- choices

  if (inherits(selected, "delayed_data") && !inherits(choices, "delayed_data")) {
    stop("If 'selected' is of class 'delayed_data', so must be 'choices'.")
  }

  if (inherits(choices, "delayed_data")) {
    return(
      structure(
        list(choices = choices, selected = selected, keep_order = keep_order, fixed = fixed),
        class = c("delayed_choices_selected", "delayed_data", "choices_selected")
      )
    )
  }

  if (!is.null(choices) && no_select_keyword %in% choices) {
    stop(paste(no_select_keyword, "is not a valid choice as it is used as a keyword"))
  }

  # remove duplicates
  choices <- vector_remove_dups(choices)
  selected <- vector_remove_dups(selected)
  checkmate::assert_subset(selected, choices)

  if (!keep_order && length(choices) > 0) {
    choices_in_selected <- which(choices %in% selected)
    choices <- vector_reorder(
      choices,
      c(choices_in_selected, setdiff(seq_along(choices), choices_in_selected))
    )
  }

  structure(
    list(
      choices = choices,
      selected = selected,
      fixed = fixed
    ),
    class = "choices_selected"
  )
}

#' @describeIn choices_selected Check if an object is a choices_selected class
#'
#' @param x (`choices_selected`) object to check.
#'
#' @return `is.choices_selected` returns `TRUE` if `x` inherits from a `choices_selected` object, `FALSE` otherwise.
#'
#' @export
#'
is.choices_selected <- function(x) { # nolint: object_name_linter.
  inherits(x, "choices_selected")
}

#' Add empty choice to choices selected
#'
#' `r lifecycle::badge("stable")`
#'
#' @param x (`choices_selected`) object.
#' @param multiple (`logical(1)`) whether multiple selections are allowed or not.
#'
#' @return `choices_selected` object with an empty option added to the choices.
#'
#' @export
#'
add_no_selected_choices <- function(x, multiple = FALSE) {
  if (is.null(x)) {
    choices_selected(NULL)
  } else {
    stopifnot(is.choices_selected(x))

    if (!multiple) {
      x$choices <- c(no_select_keyword, x$choices)
      if (is.null(x$selected)) x$selected <- no_select_keyword
    }

    x
  }
}

#' Check select choices for no choice made
#'
#' `r lifecycle::badge("stable")`
#'
#' @param x (`character`) Word that shall be checked for `NULL`, empty, "--no-selection".
#'
#' @return The word or `NULL`.
#'
#' @export
#'
no_selected_as_NULL <- function(x) { # nolint: object_name_linter.
  if (is.null(x) || identical(x, no_select_keyword) || x == "") {
    NULL
  } else {
    x
  }
}

## Non-exported utils functions ----
#' Modify vectors and keep attributes
#' @keywords internal
#' @noRd
#'
vector_reorder <- function(vec, idx) {
  checkmate::assert_atomic(vec)
  checkmate::assert_integer(idx, min.len = 1, lower = 1, any.missing = FALSE)
  stopifnot(length(vec) == length(idx))

  vec_attrs <- attributes(vec)

  vec <- vec[idx]

  for (vec_attrs_idx in seq_along(vec_attrs)) {
    if (length(vec_attrs[[vec_attrs_idx]]) == length(vec)) {
      vec_attrs[[vec_attrs_idx]] <- vec_attrs[[vec_attrs_idx]][idx]
    }
  }

  attributes(vec) <- vec_attrs
  vec
}

#' Remove item(s) and their attributes from vector
#' @keywords internal
#' @noRd
#'
vector_pop <- function(vec, idx) {
  checkmate::assert_atomic(vec)
  checkmate::assert_integer(idx, lower = 1, any.missing = FALSE)

  if (length(idx) == 0) {
    return(vec)
  }

  vec_attrs <- attributes(vec)
  names_vec_attrs <- names(vec_attrs)

  for (vec_attrs_idx in seq_along(vec_attrs)) {
    if (length(vec_attrs[[vec_attrs_idx]]) == length(vec) && names_vec_attrs[vec_attrs_idx] != "class") {
      vec_attrs[[vec_attrs_idx]] <- vec_attrs[[vec_attrs_idx]][-idx]
    }
  }

  vec <- vec[-idx]
  attributes(vec) <- vec_attrs
  vec
}

#' Remove duplicate elements or elements with the same name from a vector
#' @keywords internal
#' @noRd
#'
vector_remove_dups <- function(vec) {
  checkmate::assert_atomic(vec)

  idx <- which(duplicated(vec))

  if (length(idx) == 0) {
    vec
  } else if (is.null(attributes(vec))) {
    unique(vec)
  } else if (identical(names(attributes(vec)), "names")) {
    vec[-idx]
  } else {
    vector_pop(vec, idx)
  }
}

#' Aggregates data extract selectors
#'
#' Simplifies `selector_list` into aggregated list with one element per
#' same selector - same dataset, same filter configuration and same reshape status.
#'
#' @inheritParams get_merge_call
#'
#' @return (`list`) simplified selectors with aggregated set of filters,
#' selections, reshapes etc. All necessary data for merging.
#'
#' @keywords internal
#'
get_dplyr_call_data <- function(selector_list, join_keys = teal.data::join_keys()) {
  logger::log_trace("get_dplyr_call_data called with: { paste(names(selector_list), collapse = ', ') } selectors.")
  checkmate::assert_class(join_keys, "join_keys")
  lapply(selector_list, check_selector)

  all_merge_key_list <- get_merge_key_grid(selector_list, join_keys)
  res <- lapply(
    seq_along(selector_list),
    function(idx) {
      internal_id <- selector_list[[idx]]$internal_id

      merge_keys_list <- all_merge_key_list[[idx]]

      merge_keys <- if (length(merge_keys_list) > 1) {
        unique(unlist(lapply(merge_keys_list[-idx], names)))
      } else {
        names(merge_keys_list[[1]])
      }

      if (isFALSE(selector_list[[idx]]$reshape)) {
        unite_cols <- character(0)
        pivot_longer_cols <- character(0)
        unite_vals <- character(0)
      } else {
        unite_cols <- get_reshape_unite_col(selector_list[[idx]])
        pivot_longer_cols <- get_pivot_longer_col(selector_list[[idx]])
        unite_vals <- get_reshape_unite_vals(selector_list[[idx]])
      }

      selector_cols <- c(selector_list[[idx]]$select)
      init_select_cols <- unique(c(pivot_longer_cols, selector_cols))
      init_select_cols_with_keys <- unique(c(merge_keys, unite_cols, pivot_longer_cols, selector_cols))
      # can change order of keys

      list(
        internal_id = internal_id,
        merge_keys_list = merge_keys_list,
        unite_cols = unite_cols,
        unite_vals = unite_vals,
        pivot_longer_cols = pivot_longer_cols,
        selector_cols = selector_cols,
        init_select_cols_with_keys = init_select_cols_with_keys,
        init_select_cols = init_select_cols
      )
    }
  )

  # rename duplicated non-key columns
  all_cols <- unlist(lapply(res, `[[`, "init_select_cols"))
  for (idx1 in seq_along(res)) {
    init_select_cols <- res[[idx1]]$init_select_cols
    internal_id <- res[[idx1]]$internal_id
    selector_cols <- res[[idx1]]$selector_cols
    unite_cols <- res[[idx1]]$unite_cols
    unite_vals <- res[[idx1]]$unite_vals
    pivot_longer_cols <- res[[idx1]]$pivot_longer_cols
    merge_keys <- unique(unlist(res[[idx1]]$merge_keys_list))

    init_select_cols_renamed <- rename_duplicated_cols(
      setdiff(init_select_cols, merge_keys),
      internal_id,
      setdiff(selector_cols, unite_cols),
      all_cols
    )

    pivot_longer_cols_renamed <- rename_duplicated_cols(
      pivot_longer_cols,
      internal_id,
      setdiff(selector_cols, unite_cols),
      all_cols
    )

    pivot_longer_unite_cols_renamed <- if (rlang::is_empty(unite_vals)) { # nolint: object_length_linter.
      pivot_longer_cols_renamed
    } else {
      Reduce(
        append,
        mapply(
          function(x1, name) {
            stats::setNames(paste(x1, unite_vals, sep = "_"), rep(name, length(unite_vals)))
          },
          x1 = pivot_longer_cols_renamed,
          name = pivot_longer_cols,
          SIMPLIFY = FALSE,
          USE.NAMES = FALSE
        )
      )
    }

    selector_cols_renamed <- rename_duplicated_cols(
      init_select_cols,
      internal_id,
      setdiff(selector_cols, unite_cols),
      all_cols[!all_cols %in% merge_keys]
    )

    out_cols_renamed <- if (!rlang::is_empty(pivot_longer_unite_cols_renamed)) {
      pivot_longer_unite_cols_renamed
    } else {
      selector_cols_renamed
    }

    res[[idx1]]$init_select_cols_renamed <- init_select_cols_renamed
    res[[idx1]]$pivot_longer_cols_renamed <- pivot_longer_cols_renamed
    res[[idx1]]$out_cols_renamed <- out_cols_renamed
  }
  res
}

#' Parses filter, select, rename and reshape call
#'
#' @inheritParams get_dplyr_call_data
#'
#' @param idx optional (`integer`) current selector index in all selectors list.
#' @param dplyr_call_data (`list`) simplified selectors with aggregated set of filters,
#' selections, reshapes etc. All necessary data for merging.
#' @param data (`NULL` or named `list`) of datasets.
#'
#' @return (`call`) filter, select, rename and reshape call.
#'
#' @keywords internal
#'
get_dplyr_call <- function(selector_list,
                           idx = 1L,
                           join_keys = teal.data::join_keys(),
                           dplyr_call_data = get_dplyr_call_data(selector_list, join_keys = join_keys),
                           datasets = NULL) {
  logger::log_trace(
    paste(
      "get_dplyr_call called with:",
      "{ paste(names(datasets), collapse = ', ') } datasets;",
      "{ paste(names(selector_list), collapse = ', ') } selectors."
    )
  )
  lapply(selector_list, check_selector)
  checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)
  checkmate::assert_integer(idx, len = 1, any.missing = FALSE)

  n_selectors <- length(selector_list)

  dataname_filtered <- as.name(selector_list[[idx]]$dataname)

  filter_call <- get_filter_call(selector_list[[idx]]$filters, selector_list[[idx]]$dataname, datasets)

  select_call <- get_select_call(dplyr_call_data[[idx]]$init_select_cols_with_keys)

  rename_call <- if (n_selectors > 1) {
    get_rename_call(dplyr_call_data = dplyr_call_data, idx = idx)
  } else {
    NULL
  }

  reshape_call <- if (isTRUE(selector_list[[idx]]$reshape)) {
    get_reshape_call(dplyr_call_data = dplyr_call_data, idx = idx)
  } else {
    NULL
  }

  Reduce(
    function(x, y) call("%>%", x, y),
    Filter(function(x) !is.null(x), c(dataname_filtered, filter_call, select_call, rename_call, reshape_call))
  )
}

#' Parse `dplyr` select call
#'
#' @param select (`character`) vector of selected column names.
#'
#' @return `dplyr` select `call`.
#'
#' @keywords internal
#'
get_select_call <- function(select) {
  logger::log_trace("get_select_call called with: { paste(select, collapse = ', ') } columns.")
  if (is.null(select) || length(select) == 0) {
    return(NULL)
  }

  select <- unique(select)

  as.call(c(list(quote(dplyr::select)), lapply(select, as.name)))
}

#' Build a `dplyr` filter call
#'
#' @param filter (`list`) Either list of lists or list with `select` and `selected` items.
#' @param dataname (`NULL` or `character`) name of dataset.
#' @param datasets (`NULL` or named `list`).
#'
#' @return `dplyr` filter `call`.
#'
#' @keywords internal
#'
get_filter_call <- function(filter, dataname = NULL, datasets = NULL) {
  logger::log_trace(
    paste(
      "get_filter_call called with:",
      "{ dataname } dataset;",
      "{ paste(sapply(filter, function(x) x$columns), collapse = ', ') } filters."
    )
  )
  checkmate::assert_list(datasets, types = "reactive", names = "named", null.ok = TRUE)
  if (is.null(filter)) {
    return(NULL)
  }

  stopifnot(
    (!is.null(dataname) && is.null(datasets)) ||
      (is.null(dataname) && is.null(datasets)) ||
      (!is.null(datasets) && isTRUE(dataname %in% names(datasets)))
  )

  get_filter_call_internal <- function(filter, dataname, datasets) {
    if (rlang::is_empty(filter$selected)) {
      return(FALSE)
    }

    keys <- filter$columns
    datas_vars <- if (!is.null(datasets)) datasets[[dataname]]() else NULL

    if (!is.null(datas_vars)) {
      u_variables <- unique(apply(datas_vars[, keys, drop = FALSE], 1, function(x) paste(x, collapse = "-")))
      selected <- if (length(keys) == 1) {
        selected_single <- unlist(filter$selected)
        # We need character NA as for rest vars the NA is translated to "NA" by paste function
        selected_single[is.na(selected_single)] <- "NA"
        selected_single
      } else {
        unlist(lapply(filter$selected, function(x) paste(x, collapse = "-")))
      }
      # we don't want to process the key which all values are selected
      # this means that call for this key is redundant and will be skipped
      if (all(u_variables %in% selected)) {
        keys <- NULL
      }
    }

    if (length(keys) == 1) {
      key_name <- unlist(keys)
      key_value <- unlist(filter$selected)
      varname <- if (isTRUE(inherits(datas_vars[[key_name]], c("POSIXct", "POSIXlt", "POSIXt")))) {
        bquote(trunc(.(as.name(key_name))))
      } else {
        as.name(key_name)
      }

      if (length(key_value) == 1 && is.na(key_value)) {
        call("is.na", as.name(key_name))
      } else {
        call_condition_choice(varname = varname, choices = key_value)
      }
    } else if (length(keys) > 1) {
      calls_combine_by(
        "|",
        lapply(
          filter$selected,
          function(keys_values) {
            res <- calls_combine_by(
              "&",
              Map(
                keys,
                keys_values,
                f = function(key_name, key_value) {
                  if (is.na(key_value)) {
                    call("is.na", as.name(key_name))
                  } else {
                    varname <- if (isTRUE(inherits(datas_vars[[key_name]], c("POSIXct", "POSIXlt", "POSIXt")))) {
                      bquote(trunc(.(as.name(key_name))))
                    } else {
                      as.name(key_name)
                    }

                    call_condition_choice(
                      varname = varname,
                      key_value
                    )
                  }
                }
              )
            )
            call("(", res)
          }
        )
      )
    }
  }

  internal <- if (length(filter) == 1) {
    get_filter_call_internal(filter[[1]], dataname, datasets)
  } else {
    res <- Filter(Negate(is.null), Map(function(x) get_filter_call_internal(x, dataname, datasets), filter))
    calls_combine_by("&", res)
  }


  if (!is.null(internal)) {
    as.call(c(quote(dplyr::filter), internal))
  } else {
    NULL
  }
}

#' Remove duplicated columns
#' @keywords internal
#' @noRd
#'
rename_duplicated_cols <- function(x, internal_id, selected_cols, all_cols) {
  all_cols_dups <- all_cols[duplicated(all_cols)]
  vapply(
    x,
    function(y) {
      ifelse(y %in% selected_cols && y %in% all_cols_dups, paste0(internal_id, ".", y), y)
    },
    character(1)
  )
}

#' Returns `dplyr` rename call
#'
#' Rename is used only if there are duplicated columns.
#'
#' @inheritParams get_dplyr_call
#'
#' @return (`call`) `dplyr` rename call.
#'
#' @keywords internal
#'
get_rename_call <- function(selector_list = list(),
                            idx = 1L,
                            join_keys = teal.data::join_keys(),
                            dplyr_call_data = get_dplyr_call_data(selector_list, join_keys = join_keys)) {
  checkmate::assert_integer(idx, len = 1, any.missing = FALSE)
  stopifnot(length(dplyr_call_data) >= idx)
  logger::log_trace(
    paste(
      "get_rename_call called with:",
      "{ dplyr_call_data[[idx]]$internal_id } selector;",
      "{ paste(dplyr_call_data[[idx]]$init_select_cols_renamed, collapse = ', ') } renamed columns."
    )
  )

  lapply(selector_list, check_selector)

  rename_dict <- dplyr_call_data[[idx]]$init_select_cols_renamed
  rename_dict <- rename_dict[names(rename_dict) != rename_dict]

  if (is.null(rename_dict) || length(rename_dict) == 0) {
    return(NULL)
  }

  internal <- stats::setNames(lapply(names(rename_dict), as.name), rename_dict)

  as.call(append(quote(dplyr::rename), internal))
}

#' Returns `dplyr` reshape call
#'
#' @inheritParams get_dplyr_call
#'
#' @return List of multiple `dplyr` calls that reshape data.
#'
#' @keywords internal
#'
get_reshape_call <- function(selector_list = list(),
                             idx = 1L,
                             join_keys = teal.data::join_keys(),
                             dplyr_call_data = get_dplyr_call_data(selector_list, join_keys = join_keys)) {
  checkmate::assert_integer(idx, len = 1, any.missing = FALSE)
  stopifnot(length(dplyr_call_data) >= idx)
  logger::log_trace(
    paste(
      "get_reshape_call called with:",
      "{ dplyr_call_data[[idx]]$internal_id } selector;",
      "{ paste(dplyr_call_data[[idx]]$unite_cols, collapse = ', ') } reshaping columns;",
      "{ paste(dplyr_call_data[[idx]]$pivot_longer_cols, collapse = ', ') } reshaped columns."
    )
  )
  lapply(selector_list, check_selector)

  pl_cols <- unname(dplyr_call_data[[idx]]$pivot_longer_cols_renamed)

  pivot_longer_call <- as.call(list(
    quote(tidyr::pivot_longer),
    cols = if (length(pl_cols)) pl_cols else quote(tidyselect::everything()),
    names_to = "MEASURE",
    values_to = "VALUE"
  ))

  unite_call <- as.call(c(
    list(quote(tidyr::unite)),
    quote(KEY),
    quote(MEASURE),
    lapply(
      dplyr_call_data[[idx]]$unite_cols,
      function(x) {
        as.name(x)
      }
    )
  ))

  pivot_wider_call <- as.call(list(
    quote(tidyr::pivot_wider),
    names_from = "KEY",
    values_from = "VALUE"
  ))

  c(pivot_longer_call, unite_call, pivot_wider_call)
}


#' Get pivot longer  columns
#'
#' Get values names which are spread into columns.
#'
#' @param selector one element of selector_list obtained by `get_dplyr_call_data`.
#'
#' @return A `character` vector of all the selected columns that are not a `keys` element.
#'
#' @keywords internal
#'
get_pivot_longer_col <- function(selector) {
  logger::log_trace("get_reshape_unite_col called with: { selector$internal_id } selector.")
  setdiff(selector$select, selector$keys)
}

#' Get unite columns
#'
#' Get key names which spreads values into columns. Reshape is done only
#' on keys which are in `filter_spec`.
#'
#' @inheritParams get_pivot_longer_col
#'
#' @return A `character` vector of all the selector's keys that are defined in the filters.
#'
#' @keywords internal
#'
get_reshape_unite_col <- function(selector) {
  logger::log_trace("get_reshape_unite_col called with: { selector$internal_id } selector.")
  intersect(
    selector$keys,
    unlist(lapply(selector$filters, `[[`, "columns"))
  )
}

#' Get unite columns values
#'
#' Get key values (levels) of the unite columns.
#'
#' @inheritParams get_pivot_longer_col
#'
#' @return A `character` vector of keys of the unite columns.
#'
#' @keywords internal
#'
get_reshape_unite_vals <- function(selector) {
  logger::log_trace("get_reshape_unite_vals called with: { selector$internal_id } selector.")
  unite_cols <- get_reshape_unite_col(selector)
  filters <- selector$filters
  filters_columns <- lapply(filters, `[[`, "columns")

  # first check if combined filter exists then check one by one
  filters_idx <- which(vapply(filters_columns, function(x) identical(unite_cols, x), logical(1)))
  if (length(filters_idx) == 0) {
    filters_idx <- which(filters_columns %in% unite_cols)
  }

  unite_cols_vals <- lapply(
    filters[filters_idx],
    function(x) {
      vapply(x$selected, paste, character(1), collapse = "_")
    }
  )
  unite_cols_vals <- unite_cols_vals[vapply(unite_cols_vals, length, integer(1)) > 0]

  if (length(unite_cols_vals) > 0) {
    grid <- do.call(expand.grid, args = list(unite_cols_vals, stringsAsFactors = FALSE))
    apply(grid, 1, paste, collapse = "_")
  } else {
    character(0)
  }
}

#' Merge the datasets on the keys
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Combines/merges multiple datasets with specified keys attribute.
#'
#' @details
#' Internally this function uses calls to allow reproducibility.
#'
#' This function is often used inside a `teal` module server function with the
#' `selectors` being the output of `data_extract_srv` or `data_extract_multiple_srv`.
#'
#' ```
#' # inside teal module server function
#'
#' response <- data_extract_srv(
#'   id = "reponse",
#'   data_extract_spec = response_spec,
#'   datasets = datasets
#' )
#' regressor <- data_extract_srv(
#'   id = "regressor",
#'   data_extract_spec = regressor_spec,
#'   datasets = datasets
#' )
#' merged_data <- merge_datasets(list(regressor(), response()))
#' ```
#'
#' @inheritParams merge_expression_srv
#'
#' @return `merged_dataset` list containing:
#' * `expr` (`list` of `call`) code needed to replicate merged dataset;
#' * `columns_source` (`list`) of column names selected for particular selector;
#' Each list element contains named character vector where:
#'   * Values are the names of the columns in the `ANL`. In case if the same column name is selected in more than one
#'     selector it gets prefixed by the id of the selector. For example if two `data_extract` have id `x`, `y`, then
#'     their duplicated selected variable (for example `AGE`) is prefixed to be `x.AGE` and `y.AGE`;
#'   * Names of the vector denote names of the variables in the input dataset;
#'   * `attr(,"dataname")` to indicate which dataset variable is merged from;
#'   * `attr(, "always selected")` to denote the names of the variables which need to be always selected;
#' * `keys` (`list`) the keys of the merged dataset;
#' * `filter_info` (`list`) The information given by the user. This information
#'    defines the filters that are applied on the data. Additionally it defines
#'    the variables that are selected from the data sets.
#'
#' @examples
#' library(shiny)
#' library(teal.data)
#'
#' X <- data.frame(A = c(1, 1:3), B = 2:5, D = 1:4, E = letters[1:4], G = letters[6:9])
#' Y <- data.frame(A = c(1, 1, 2), B = 2:4, C = c(4, 4:5), E = letters[4:6], G = letters[1:3])
#' join_keys <- join_keys(join_key("X", "Y", c("A", "B")))
#'
#' selector_list <- list(
#'   list(
#'     dataname = "X",
#'     filters = NULL,
#'     select = "E",
#'     keys = c("A", "B"),
#'     reshape = FALSE,
#'     internal_id = "x"
#'   ),
#'   list(
#'     dataname = "Y",
#'     filters = NULL,
#'     select = "G",
#'     keys = c("A", "C"),
#'     reshape = FALSE,
#'     internal_id = "y"
#'   )
#' )
#'
#' data_list <- list(X = reactive(X), Y = reactive(Y))
#'
#' merged_datasets <- isolate(
#'   merge_datasets(
#'     selector_list = selector_list,
#'     datasets = data_list,
#'     join_keys = join_keys
#'   )
#' )
#'
#' paste(merged_datasets$expr)
#' @export
#'
merge_datasets <- function(selector_list, datasets, join_keys, merge_function = "dplyr::full_join", anl_name = "ANL") {
  logger::log_trace(
    paste(
      "merge_datasets called with:",
      "{ paste(names(datasets), collapse = ', ') } datasets;",
      "{ paste(names(selector_list), collapse = ', ') } selectors;",
      "{ merge_function } merge function."
    )
  )

  checkmate::assert_list(selector_list, min.len = 1)
  checkmate::assert_string(anl_name)
  checkmate::assert_list(datasets, names = "named")
  checkmate::assert_class(join_keys, "join_keys")
  stopifnot(attr(regexec("[A-Za-z0-9\\_]*", anl_name)[[1]], "match.length") == nchar(anl_name))
  lapply(selector_list, check_selector)
  merge_selectors_out <- merge_selectors(selector_list)
  merged_selector_list <- merge_selectors_out[[1]]
  merged_selector_map_id <- merge_selectors_out[[2]]
  check_data_merge_selectors(merged_selector_list)

  dplyr_call_data <- get_dplyr_call_data(merged_selector_list, join_keys)

  validate_keys_sufficient(join_keys, merged_selector_list)

  columns_source <- mapply(
    function(id_from, id_to) {
      id_data <- vapply(dplyr_call_data, `[[`, character(1), "internal_id")
      out_cols <- dplyr_call_data[[which(id_to == id_data)]][["out_cols_renamed"]]
      id_selector <- vapply(selector_list, `[[`, character(1), "internal_id")
      res <- out_cols[names(out_cols) %in% selector_list[[which(id_from == id_selector)]][["select"]]]
      attr(res, "dataname") <- selector_list[[which(id_from == id_selector)]]$dataname
      always_selected <- selector_list[[which(id_from == id_selector)]]$always_selected
      if (is.null(always_selected)) {
        attr(res, "always_selected") <- character(0)
      } else {
        attr(res, "always_selected") <- always_selected
      }
      res
    },
    id_from = names(merged_selector_map_id),
    id_to = merged_selector_map_id,
    SIMPLIFY = FALSE
  )

  dplyr_calls <- lapply(seq_along(merged_selector_list), function(idx) {
    dplyr_call <- get_dplyr_call(
      selector_list = merged_selector_list,
      idx = idx,
      dplyr_call_data = dplyr_call_data,
      datasets = datasets
    )
    anl_i_call <- call("<-", as.name(paste0(anl_name, "_", idx)), dplyr_call)
    anl_i_call
  })

  anl_merge_calls <- get_merge_call(
    selector_list = merged_selector_list,
    dplyr_call_data = dplyr_call_data,
    merge_function = merge_function,
    anl_name = anl_name
  )

  anl_relabel_call <- get_anl_relabel_call(
    columns_source = get_relabel_cols(columns_source, dplyr_call_data), # don't relabel reshaped cols
    datasets = datasets,
    anl_name = anl_name
  )

  all_calls_expression <- c(dplyr_calls, anl_merge_calls, anl_relabel_call)

  # keys in each merged_selector_list element should be identical
  # so take first one
  keys <- merged_selector_list[[1]]$keys

  filter_info <- lapply(merged_selector_list, "[[", "filters")

  res <- list(
    expr = all_calls_expression,
    columns_source = columns_source,
    keys = keys,
    filter_info = filter_info
  )
  logger::log_trace("merge_datasets merge code executed resulting in { anl_name } dataset.")
  res
}

#' Merge selectors when `dataname`, `reshape`, `filters` and `keys` entries are identical
#'
#' @inheritParams merge_datasets
#'
#' @return List of merged selectors or original parameter if the conditions to merge are
#' not applicable.
#'
#' @keywords internal
#'
merge_selectors <- function(selector_list) {
  logger::log_trace("merge_selectors called with: { paste(names(selector_list), collapse = ', ') } selectors.")
  checkmate::assert_list(selector_list, min.len = 1)
  lapply(selector_list, check_selector)

  # merge map - idx to value
  # e.g. 1 2 1 means that 3rd selector is merged to 1st selector
  res_map_idx <- seq_along(selector_list)
  for (idx1 in res_map_idx) {
    selector_idx1 <- selector_list[[idx1]]
    for (idx2 in utils::tail(seq_along(res_map_idx), -idx1)) {
      if (res_map_idx[idx2] != idx2) {
        next
      }
      selector_idx2 <- selector_list[[idx2]]
      if (
        identical(selector_idx1$dataname, selector_idx2$dataname) &&
          identical(selector_idx1$reshape, selector_idx2$reshape) &&
          identical(selector_idx1$filters, selector_idx2$filters) &&
          identical(selector_idx1$keys, selector_idx2$keys)
      ) {
        res_map_idx[idx2] <- idx1
      }
    }
  }

  res_map_id <- stats::setNames(
    vapply(selector_list[res_map_idx], `[[`, character(1), "internal_id"),
    vapply(selector_list, `[[`, character(1), "internal_id")
  )


  res_list <- selector_list
  for (idx in seq_along(res_map_idx)) {
    idx_val <- res_map_idx[[idx]]
    if (idx != idx_val) {
      # merge selector to the "first" identical subset
      res_list[[idx_val]]$select <- union(res_list[[idx_val]]$select, selector_list[[idx]]$select)
    }
  }
  for (idx in rev(seq_along(res_map_idx))) {
    idx_val <- res_map_idx[[idx]]
    if (idx != idx_val) {
      res_list[[idx]] <- NULL
    }
  }

  list(res_list, res_map_id)
}


#' Validate data_extracts in merge_datasets
#'
#' Validate selected inputs from data_extract before passing to data_merge to avoid
#' `dplyr` errors or unexpected results.
#'
#' @inheritParams merge_datasets
#'
#' @return `NULL` if check is successful and `shiny` validate error otherwise.
#'
#' @keywords internal
#'
check_data_merge_selectors <- function(selector_list) {
  # check if reshape n empt select or just primary keys
  lapply(selector_list, function(x) {
    if (x$reshape & length(setdiff(x$select, x$keys)) == 0) {
      validate(need(
        FALSE,
        "Error in data_extract_spec setup:\
        \tPlease select non-key column to be reshaped from long to wide format."
      ))
    }
  })
  NULL
}

#' Validates whether the provided keys are sufficient to merge the datasets slices
#'
#' @note
#' The keys are not sufficient if the datasets slices described in
#' `merged_selector_list` come from datasets, which don't have the
#' appropriate join keys in `join_keys`.
#'
#' @param join_keys (`join_keys`) the provided join keys.
#' @param merged_selector_list (`list`) the specification of datasets' slices to merge.
#'
#' @return `TRUE` if the provided keys meet the requirement and `shiny`
#' validate error otherwise.
#'
#' @keywords internal
#'
validate_keys_sufficient <- function(join_keys, merged_selector_list) {
  validate(
    need(
      are_needed_keys_provided(join_keys, merged_selector_list),
      message = paste(
        "Cannot merge at least two dataset extracts.",
        "Make sure all datasets used for merging have appropriate keys."
      )
    )
  )

  TRUE
}

#' Checks whether the provided slices have the corresponding join keys
#'
#' @note
#' `merged_selector_list` contains a list of descriptions of data frame slices;
#' each coming from a single dataset. This function checks whether all pairs
#' of the datasets have the join keys needed to merge the slices.
#'
#' @inheritParams validate_keys_sufficient
#'
#' @return `TRUE` if all pairs of the slices have the corresponding keys and
#' `FALSE` otherwise.
#'
#' @keywords internal
#'
are_needed_keys_provided <- function(join_keys, merged_selector_list) {
  # because one slice doesn't have to be merged with anything
  if (length(merged_selector_list) <= 1) {
    return(TRUE)
  }

  do_join_keys_exist <- function(dataset_name1, dataset_name2, join_keys) {
    length(join_keys[dataset_name1, dataset_name2] > 0)
  }

  datasets_names <- vapply(merged_selector_list, function(slice) slice[["dataname"]], FUN.VALUE = character(1))
  datasets_names_pairs <- utils::combn(datasets_names, m = 2)
  datasets_names_pairs <- datasets_names_pairs[, !duplicated(t(datasets_names_pairs)), drop = FALSE]

  datasets_pairs_keys_present <- apply(
    datasets_names_pairs,
    MARGIN = 2,
    FUN = function(names_pair) do_join_keys_exist(names_pair[1], names_pair[2], join_keys)
  )

  all(datasets_pairs_keys_present)
}

#' Get merge call from a list of selectors
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Creates list of calls depending on selector(s) and type of the merge.
#' The merge order is the same as in selectors passed to the function.
#'
#' @inheritParams merge_datasets
#' @param join_keys (`join_keys`) nested list of keys used for joining.
#' @param dplyr_call_data (`list`) simplified selectors with aggregated set of filters.
#'
#' @return List with merge `call` elements.
#'
#' @export
#'
get_merge_call <- function(selector_list,
                           join_keys = teal.data::join_keys(),
                           dplyr_call_data = get_dplyr_call_data(selector_list, join_keys = join_keys),
                           merge_function = "dplyr::full_join",
                           anl_name = "ANL") {
  if (!missing(selector_list)) {
    checkmate::assert_list(selector_list, min.len = 1)
    lapply(selector_list, check_selector)
    logger::log_trace(
      paste(
        "get_merge_call called with: { paste(names(selector_list), collapse = ', ') } selectors;",
        "{ merge_function } merge function."
      )
    )
  } else {
    logger::log_trace(
      paste(
        "get_merge_call called with:",
        "{ paste(sapply(dplyr_call_data, `[[`, 'internal_id'), collapse = ', ') } selectors;",
        "{ merge_function } merge function."
      )
    )
  }

  checkmate::assert_string(anl_name)
  stopifnot(attr(regexec("[A-Za-z0-9\\_]*", anl_name)[[1]], "match.length") == nchar(anl_name))
  check_merge_function(merge_function)


  n_selectors <- if (!missing(selector_list)) {
    length(selector_list)
  } else {
    length(dplyr_call_data)
  }

  anl_merge_calls <- list(
    call("<-", as.name(anl_name), as.name(paste0(anl_name, "_", 1)))
  )

  for (idx in seq_len(n_selectors)[-1]) {
    anl_merge_call_i <- call(
      "<-",
      as.name(anl_name),
      {
        merge_key_i <- get_merge_key_i(idx = idx, dplyr_call_data = dplyr_call_data)
        is_merge_key_pair <- vapply(merge_key_i, function(x) length(names(x)) == 1, logical(1))

        join_call <- as.call(
          c(
            rlang::parse_expr(merge_function),
            list(
              as.name(anl_name),
              as.name(paste0(anl_name, "_", idx))
            ),
            if (!rlang::is_empty(merge_key_i)) {
              list(
                by = parse_merge_key_i(merge_key = merge_key_i)
              )
            }
          )
        )

        # mutate call to get second key if any pair key
        # e.g. full_join(dt1, dt2, by = c("key1" = "key2")) %>% mutate(key2 = key1)
        # it's because dplyr joins preserve only key from LHS data
        mutate_call <- if (any(is_merge_key_pair)) {
          merge_key_pairs <- merge_key_i[is_merge_key_pair]
          # drop duplicates ignoring names
          idx <- vapply(unique(unlist(merge_key_pairs)), function(x1) {
            which.min(vapply(merge_key_pairs, function(x2) x2 == x1, logical(1)))
          }, integer(1))

          merge_key_pairs <- merge_key_pairs[idx]
          as.call(
            append(
              quote(dplyr::mutate),
              stats::setNames(
                lapply(merge_key_pairs, function(x) as.name(names(x))),
                merge_key_pairs
              )
            )
          )
        } else {
          NULL
        }

        Reduce(
          function(x, y) call("%>%", x, y),
          c(join_call, mutate_call)
        )
      }
    )

    anl_merge_calls <- append(
      anl_merge_calls,
      anl_merge_call_i
    )
  }

  anl_merge_calls
}

#' Gets merge key pair list from keys list
#'
#' @inheritParams get_merge_call
#'
#' @return List of merge key pairs between all datasets.
#'
#' @keywords internal
#'
get_merge_key_grid <- function(selector_list, join_keys = teal.data::join_keys()) {
  logger::log_trace(
    "get_merge_key_grid called with: { paste(names(selector_list), collapse = ', ') } selectors."
  )

  lapply(
    selector_list,
    function(selector_from) {
      lapply(
        selector_list,
        function(selector_to) {
          get_merge_key_pair(
            selector_from,
            selector_to,
            join_keys[selector_from$dataname, selector_to$dataname]
          )
        }
      )
    }
  )
}

#' Gets keys vector from keys list
#'
#' @details
#' This function covers up to now 4 cases:
#'
#' * Dataset without parent: Primary keys are returned;
#' * Dataset source = dataset target:
#' The primary keys subtracted of all key columns that get purely filtered.
#' This means just one value would be left after filtering inside this column
#' Then it can be taken out;
#' * Target `dataname` is parent foreign keys;
#' * Any other case foreign keys;
#'
#' @param selector_from (`list`) of `data_extract_srv` objects.
#' @param selector_to (`list`) of `data_extract_srv` objects.
#' @param key_from (`character`) keys used in the first selector while joining.
#'
#' @return `character` vector of selector keys.
#'
#' @keywords internal
#'
get_merge_key_pair <- function(selector_from, selector_to, key_from) {
  logger::log_trace(
    paste(
      "get_merge_key_pair called with:",
      "{ paste(selector_from$internal_id, selector_to$internal_id, sep = ', ') } selectors;",
      "{ paste(key_from, collapse = ', ') } keys."
    )
  )
  check_selector(selector_from)
  check_selector(selector_to)
  checkmate::test_character(key_from, min.len = 0, any.missing = FALSE)

  res <- if (identical(selector_from$dataname, selector_to$dataname)) {
    # key is dropped if reshape or if filtered out (only one level selected)
    keys_dropped <- if (isTRUE(selector_from$reshape)) {
      get_reshape_unite_col(selector_from)
    } else {
      get_dropped_filters(selector_from)
    }
    res <- setdiff(
      key_from,
      keys_dropped
    )
    if (!rlang::is_empty(res)) res <- rlang::set_names(res)
    res
  } else {
    key_from
  }
  logger::log_trace("get_merge_key_pair returns { paste(res, collapse = ', ') } merge keys.")
  res
}

#' Gets keys needed for join call of two selectors
#'
#' @inheritParams get_merge_call
#' @param idx (optional `integer`) current selector index in all selectors list.
#'
#' @return `character` list of keys.
#'
#' @keywords internal
#'
get_merge_key_i <- function(selector_list, idx, dplyr_call_data = get_dplyr_call_data(selector_list)) {
  checkmate::assert_integer(idx, len = 1, any.missing = FALSE, lower = 2L)

  if (!missing(selector_list)) {
    checkmate::assert_list(selector_list, min.len = 1)
    lapply(selector_list, check_selector)

    logger::log_trace(
      paste(
        "get_merge_key_i called with:",
        "{ paste(names(selector_list), collapse = ', ') } selectors;",
        "idx = { idx }."
      )
    )
  } else {
    logger::log_trace(
      paste(
        "get_merge_key_i called with",
        "{ paste(sapply(dplyr_call_data, `[[`, 'internal_id'), collapse = ', ') } selectors;",
        "idx = { idx }."
      )
    )
  }

  merge_keys_list <- lapply(dplyr_call_data, `[[`, "merge_keys_list")

  # keys x - get from all selectors up to the current one
  keys_x <- lapply(merge_keys_list[seq_len(idx - 1)], `[[`, idx)

  # keys y - get from the current selector
  keys_y <- merge_keys_list[[idx]][seq_len(idx - 1)]

  keys_map <- lapply(
    seq_len(idx - 1),
    function(idx2) {
      keys_x_idx2 <- keys_x[[idx2]]
      keys_y_idx2 <- keys_y[[idx2]]
      min_length <- min(length(keys_x_idx2), length(keys_y_idx2))

      # In case the keys might be wrongly sorted, sort them
      if (!identical(keys_x_idx2[seq_len(min_length)], keys_y_idx2[seq_len(min_length)])) {
        keys_x_idx2 <- c(
          intersect(keys_x_idx2, keys_y_idx2),
          setdiff(keys_x_idx2, keys_y_idx2)
        )

        keys_y_idx2 <- c(
          intersect(keys_y_idx2, keys_x_idx2),
          setdiff(keys_y_idx2, keys_x_idx2)
        )
      }
      # cut keys case of different length
      keys_x_idx2 <- keys_x_idx2[seq_len(min_length)]
      keys_y_idx2 <- keys_y_idx2[seq_len(min_length)]

      mapply(
        function(x, y) {
          if (identical(x, y)) {
            x
          } else {
            stats::setNames(nm = y, x)
          }
        },
        keys_x_idx2,
        keys_y_idx2,
        SIMPLIFY = FALSE,
        USE.NAMES = FALSE
      )
    }
  )

  keys_map <- if (length(keys_map) > 1) {
    Reduce(append, keys_map)
  } else {
    keys_map[[1]]
  }

  keys_map <- unique(keys_map)
  logger::log_trace("get_merge_key_i returns { paste(keys_map, collapse = ' ') } unique keys.")
  keys_map
}

#' Parses merge keys
#'
#' @inheritParams get_merge_call
#' @param merge_key keys obtained from `get_merge_key_i`.
#' @param idx optional (`integer`) current selector index in all selectors list.
#'
#' @return `call` with merge keys.
#'
#' @keywords internal
#'
parse_merge_key_i <- function(selector_list,
                              idx,
                              dplyr_call_data = get_dplyr_call_data(selector_list),
                              merge_key = get_merge_key_i(selector_list, idx, dplyr_call_data)) {
  logger::log_trace("parse_merge_key_i called with { paste(merge_key, collapse = ' ') } keys.")
  as.call(
    append(
      quote(c),
      unlist(merge_key)
    )
  )
}

#' Names of filtered-out filters dropped from selection
#'
#' @details
#' Names of filtered-out filters dropped from automatic selection
#' (key vars are automatically included in select).
#' Dropped filter is filter which became not unique for all observations.
#' This means that if variable is filtered to just one level,
#' it's not a key anymore.
#'
#' Other variables used in filter should also be dropped from automatic
#' selection, unless they have been selected.
#'
#' @inheritParams get_pivot_longer_col
#'
#' @return Vector of `character` names of the filters which should be dropped from select call.
#'
#' @keywords internal
#'
get_dropped_filters <- function(selector) {
  logger::log_trace("get_dropped_filters called with { selector$internal_id } selector.")
  unlist(
    lapply(selector$filters, function(x) {
      if (isFALSE(x$drop_keys)) {
        NULL
      } else if (length(x$columns) > 1) {
        # concatenated filters
        single_selection <- sapply(seq_along(x$columns), function(i) length(unique(sapply(x$selected, `[[`, i))) == 1)
        x$columns[single_selection]
      } else {
        # one filter in one input
        if (isFALSE(x$multiple) || length(x$selected) == 1) x$columns
      }
    })
  )
}


#' Gets the relabel call
#'
#' `r lifecycle::badge("stable")`
#'
#' @inheritParams merge_datasets
#' @param columns_source (named `list`)
#' where names are column names, values are labels + additional attribute `dataname`
#'
#' @return (`call`) to relabel `dataset` and assign to `anl_name`.
#'
#' @export
get_anl_relabel_call <- function(columns_source, datasets, anl_name = "ANL") {
  logger::log_trace(
    paste(
      "get_anl_relabel_call called with:",
      "{ paste(names(columns_source), collapse = ', ') } columns_source;",
      "{ anl_name } merged dataset."
    )
  )
  checkmate::assert_string(anl_name)
  stopifnot(attr(regexec("[A-Za-z0-9\\_]*", anl_name)[[1]], "match.length") == nchar(anl_name))
  labels_vector <- Reduce(
    function(x, y) append(x, y),
    lapply(
      columns_source,
      function(selector) {
        column_names <- names(selector)
        if (rlang::is_empty(column_names)) {
          return(NULL)
        }

        data_used <- datasets[[attr(selector, "dataname")]]
        labels <- teal.data::col_labels(data_used(), fill = FALSE)
        column_labels <- labels[intersect(colnames(data_used()), column_names)]

        # NULL for no labels at all, character(0) for no labels for a given columns
        return(
          if (rlang::is_empty(column_labels)) {
            column_labels
          } else {
            stats::setNames(
              column_labels,
              selector[names(column_labels)]
            )
          }
        )
      }
    )
  )

  if (length(labels_vector) == 0 || all(is.na(labels_vector))) {
    return(NULL)
  }

  relabel_call <- call(
    "%>%",
    as.name(anl_name),
    get_relabel_call(labels_vector)
  )

  relabel_and_assign_call <- call(
    "<-",
    as.name(anl_name),
    relabel_call
  )

  relabel_and_assign_call
}

#' Create relabel call from named character
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Function creates relabel call from named character.
#'
#' @param labels (named `character`)
#' where name is name is function argument name and value is a function argument value.
#'
#' @return `call` object with relabel step.
#'
#' @examples
#' get_relabel_call(
#'   labels = c(
#'     x = as.name("ANL"),
#'     AGE = "Age",
#'     AVAL = "Continuous variable"
#'   )
#' )
#'
#' get_relabel_call(
#'   labels = c(
#'     AGE = "Age",
#'     AVAL = "Continuous variable"
#'   )
#' )
#' @export
get_relabel_call <- function(labels) {
  logger::log_trace("get_relabel_call called with: { paste(labels, collapse = ' ' ) } labels.")
  if (length(stats::na.omit(labels)) == 0 || is.null(names(labels))) {
    return(NULL)
  }
  labels <- labels[!duplicated(names(labels))]
  labels <- labels[!is.na(labels)]

  as.call(
    append(
      quote(teal.data::col_relabel),
      labels
    )
  )
}

#' Get columns to relabel
#'
#' Get columns to relabel excluding these which has been reshaped (pivot_wider).
#'
#' @param columns_source (`list`)
#' @param dplyr_call_data (`list`)
#'
#' @return `columns_source` list without columns that have been reshaped.
#'
#' @keywords internal
#'
get_relabel_cols <- function(columns_source, dplyr_call_data) {
  logger::log_trace(
    "get_relabel_cols called with: { paste(names(columns_source), collapse = ', ') } columns_source."
  )
  pivot_longer_cols <- unlist(unname(lapply(dplyr_call_data, function(x) x[["pivot_longer_cols_renamed"]])))
  lapply(
    columns_source,
    function(column_source) {
      dataname <- attr(column_source, "dataname")
      column_source <- column_source[!names(column_source) %in% pivot_longer_cols]
      if (length(column_source) == 0) {
        return(NULL)
      }
      attr(column_source, "dataname") <- dataname
      column_source
    }
  )
}

#' Set "`<choice>:<label>`" type of names
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' This is often useful for [choices_selected()] as it marks up the drop-down boxes
#' for [shiny::selectInput()].
#'
#' @details
#' If either `choices` or `labels` are factors, they are coerced to character.
#' Duplicated elements from `choices` get removed.
#'
#' @param choices (`character` or `factor` or `numeric` or `logical`) vector.
#' @param labels (`character`) vector containing labels to be applied to `choices`.
#' If `NA` then "Label Missing" will be used.
#' @param subset (`character` or `factor` or `numeric` or `logical`) vector that
#' is a subset of `choices`.
#' This is useful if only a few variables need to be named.
#' If this argument is used, the returned vector will match its order.
#' @param types (`character`) vector containing the types of the columns to be used for applying the appropriate
#' icons to the [choices_selected] drop down box (e.g. "numeric").
#'
#' @return Named `character` vector.
#'
#' @examples
#' library(shiny)
#' library(teal.data)
#'
#' ADSL <- teal.transform::rADSL
#' ADTTE <- teal.transform::rADTTE
#'
#' choices1 <- choices_labeled(names(ADSL), col_labels(ADSL, fill = FALSE))
#' choices2 <- choices_labeled(ADTTE$PARAMCD, ADTTE$PARAM)
#'
#' # if only a subset of variables are needed, use subset argument
#' choices3 <- choices_labeled(
#'   names(ADSL),
#'   col_labels(ADSL, fill = FALSE),
#'   subset = c("ARMCD", "ARM")
#' )
#'
#' ui <- fluidPage(
#'   selectInput("c1",
#'     label = "Choices from ADSL",
#'     choices = choices1,
#'     selected = choices1[1]
#'   ),
#'   selectInput("c2",
#'     label = "Choices from ADTTE",
#'     choices = choices2,
#'     selected = choices2[1]
#'   ),
#'   selectInput("c3",
#'     label = "Arm choices from ADSL",
#'     choices = choices3,
#'     selected = choices3[1]
#'   )
#' )
#' server <- function(input, output) {}
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
  if (is.factor(choices)) {
    choices <- as.character(choices)
  }

  checkmate::assert_atomic(choices, min.len = 1, any.missing = FALSE)

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

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

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

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

  if (!is.null(subset)) {
    ord <- match(subset, choices)
    choices <- choices[ord]
    raw_labels <- raw_labels[ord]
    combined_labels <- combined_labels[ord]
    types <- types[ord]
  }

  structure(
    choices,
    names = combined_labels,
    raw_labels = raw_labels,
    combined_labels = combined_labels,
    class = c("choices_labeled", "character"),
    types = types
  )
}

#' Variable label extraction and custom selection from data
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Wrapper on [choices_labeled] to label variables basing on existing labels in data.
#'
#' @rdname variable_choices
#'
#' @param data (`data.frame` or `character`)
#' If `data.frame`, then data to extract labels from.
#' If `character`, then name of the dataset to extract data from once available.
#' @param subset (`character` or `function`)
#' If `character`, then a vector of column names.
#' If `function`, then this function is used to determine the possible columns (e.g. all factor columns).
#' In this case, the function must take only single argument "data" and return a character vector.
#'
#' See examples for more details.
#' @param key (`character`) vector with names of the variables, which are part of the primary key
#' of the `data` argument.
#'
#' This is an optional argument, which allows to identify variables associated
#' with the primary key and display the appropriate icon for them in the
#' [teal.widgets::optionalSelectInput()] widget.
#' @param fill (`logical(1)`) if `TRUE`, the function will return variable names
#' for columns with non-existent labels; otherwise will return `NA` for them.
#'
#' @return Named `character` vector with additional attributes or `delayed_data` object.
#'
#' @examples
#' library(teal.data)
#'
#' ADRS <- teal.transform::rADRS
#' variable_choices(ADRS)
#' variable_choices(ADRS, subset = c("PARAM", "PARAMCD"))
#' variable_choices(ADRS, subset = c("", "PARAM", "PARAMCD"))
#' variable_choices(
#'   ADRS,
#'   subset = c("", "PARAM", "PARAMCD"),
#'   key = default_cdisc_join_keys["ADRS", "ADRS"]
#' )
#'
#' # delayed version
#' variable_choices("ADRS", subset = c("USUBJID", "STUDYID"))
#'
#' # functional subset (with delayed data) - return only factor variables
#' variable_choices("ADRS", subset = function(data) {
#'   idx <- vapply(data, is.factor, logical(1))
#'   names(data)[idx]
#' })
#' @export
#'
variable_choices <- function(data, subset = NULL, fill = FALSE, key = NULL) {
  checkmate::assert(
    checkmate::check_character(subset, null.ok = TRUE, any.missing = FALSE),
    checkmate::check_function(subset)
  )
  checkmate::assert_flag(fill)
  checkmate::assert_character(key, null.ok = TRUE, any.missing = FALSE)

  UseMethod("variable_choices")
}

#' @rdname variable_choices
#' @export
variable_choices.character <- function(data, subset = NULL, fill = FALSE, key = NULL) {
  structure(list(data = data, subset = subset, key = key),
    class = c("delayed_variable_choices", "delayed_data", "choices_labeled")
  )
}

#' @rdname variable_choices
#' @export
variable_choices.data.frame <- function(data, subset = NULL, fill = TRUE, key = NULL) {
  checkmate::assert(
    checkmate::check_character(subset, null.ok = TRUE),
    checkmate::check_function(subset, null.ok = TRUE)
  )

  if (is.function(subset)) {
    subset <- resolve_delayed_expr(subset, ds = data, is_value_choices = FALSE)
  }

  checkmate::assert_subset(subset, c("", names(data)), empty.ok = TRUE)

  if (length(subset) == 0) {
    subset <- names(data)
  }

  key <- intersect(subset, key)

  var_types <- vapply(data, function(x) class(x)[[1]], character(1))

  if (length(key) != 0) {
    var_types[key] <- "primary_key"
  }

  if (any(duplicated(subset))) {
    warning(
      "removed duplicated entries in subset:",
      paste(unique(subset[duplicated(subset)]), collapse = ", ")
    )
    subset <- unique(subset)
  }

  if ("" %in% subset) {
    choices_labeled(
      choices = c("", names(data)),
      labels = c("", unname(teal.data::col_labels(data, fill = fill))),
      subset = subset,
      types = c("", var_types)
    )
  } else {
    choices_labeled(
      choices = names(data),
      labels = unname(teal.data::col_labels(data, fill = fill)),
      subset = subset,
      types = var_types
    )
  }
}

#' Value labeling and filtering based on variable relationship
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Wrapper on [choices_labeled] to label variable values basing on other variable values.
#'
#' @rdname value_choices
#'
#' @param data (`data.frame`, `character`)
#' If `data.frame`, then data to extract labels from.
#' If `character`, then name of the dataset to extract data from once available.
#' @param var_choices (`character` or `NULL`) vector with choices column names.
#' @param var_label (`character`) vector with labels column names.
#' @param subset (`character` or `function`)
#' If `character`, vector with values to subset.
#' If `function`, then this function is used to determine the possible columns (e.g. all factor columns).
#' In this case, the function must take only single argument "data" and return a character vector.
#'
#' See examples for more details.
#' @param sep (`character`) separator used in case of multiple column names.
#'
#' @return named character vector or `delayed_data` object.
#'
#' @examples
#' ADRS <- teal.transform::rADRS
#' value_choices(ADRS, "PARAMCD", "PARAM", subset = c("BESRSPI", "INVET"))
#' value_choices(ADRS, c("PARAMCD", "ARMCD"), c("PARAM", "ARM"))
#' value_choices(ADRS, c("PARAMCD", "ARMCD"), c("PARAM", "ARM"),
#'   subset = c("BESRSPI - ARM A", "INVET - ARM A", "OVRINV - ARM A")
#' )
#' value_choices(ADRS, c("PARAMCD", "ARMCD"), c("PARAM", "ARM"), sep = " --- ")
#'
#' # delayed version
#' value_choices("ADRS", c("PARAMCD", "ARMCD"), c("PARAM", "ARM"))
#'
#' # functional subset
#' value_choices(ADRS, "PARAMCD", "PARAM", subset = function(data) {
#'   levels(data$PARAMCD)[1:2]
#' })
#' @export
#'
value_choices <- function(data,
                          var_choices,
                          var_label = NULL,
                          subset = NULL,
                          sep = " - ") {
  checkmate::assert_character(var_choices, any.missing = FALSE)
  checkmate::assert_character(var_label, len = length(var_choices), null.ok = TRUE, any.missing = FALSE)
  checkmate::assert(
    checkmate::check_vector(subset, null.ok = TRUE),
    checkmate::check_function(subset)
  )
  checkmate::assert_string(sep)
  UseMethod("value_choices")
}

#' @rdname value_choices
#' @export
value_choices.character <- function(data,
                                    var_choices,
                                    var_label = NULL,
                                    subset = NULL,
                                    sep = " - ") {
  structure(
    list(
      data = data,
      var_choices = var_choices,
      var_label = var_label,
      subset = subset,
      sep = sep
    ),
    class = c("delayed_value_choices", "delayed_data", "choices_labeled")
  )
}

#' @rdname value_choices
#' @export
value_choices.data.frame <- function(data,
                                     var_choices,
                                     var_label = NULL,
                                     subset = NULL,
                                     sep = " - ") {
  checkmate::assert_subset(var_choices, names(data))
  checkmate::assert_subset(var_label, names(data), empty.ok = TRUE)

  df_choices <- data[var_choices]
  df_label <- data[var_label]

  for (i in seq_along(var_choices)) {
    if ("NA" %in% c(df_choices[[i]], levels(df_choices[[i]])) && any(is.na(df_choices[[i]]))) {
      warning(paste0(
        "Missing values and the string value of 'NA' both exist in the column of ", var_choices[i],
        " either as value(s) or level(s). ",
        "This will cause the missing values to be grouped with the actual string 'NA' values in the UI widget."
      ))
    }
  }

  choices <- if (
    length(var_choices) > 1 ||
      is.character(df_choices[[1]]) ||
      is.factor(df_choices[[1]]) ||
      inherits(df_choices[[1]], c("Date", "POSIXct", "POSIXlt", "POSIXt"))
  ) {
    df_choices <- dplyr::mutate_if(
      df_choices,
      .predicate = function(col) inherits(col, c("POSIXct", "POSIXlt", "POSIXt")),
      .funs = function(col) {
        if (is.null(attr(col, "tzone")) || all(attr(col, "tzone") == "")) {
          format(trunc(col), "%Y-%m-%d %H:%M:%S")
        } else {
          format(trunc(col), "%Y-%m-%d %H:%M:%S %Z")
        }
      }
    )
    apply(df_choices, 1, paste, collapse = sep)
  } else {
    df_choices[[var_choices]]
  }
  labels <- apply(df_label, 1, paste, collapse = sep)
  df <- unique(data.frame(choices, labels, stringsAsFactors = FALSE)) # unique combo of choices x labels

  if (is.function(subset)) {
    subset <- resolve_delayed_expr(subset, ds = data, is_value_choices = TRUE)
  }
  res <- choices_labeled(
    choices = df$choices,
    labels = df$labels,
    subset = subset
  )
  attr(res, "sep") <- sep
  attr(res, "var_choices") <- var_choices
  attr(res, "var_label") <- var_label
  res
}

#' @describeIn choices_labeled Print choices_labeled object
#'
#' @param x an object used to select a method.
#' @param ... further arguments passed to or from other methods.
#'
#' @export
#'
print.choices_labeled <- function(x, ...) {
  cat(
    sprintf("number of choices: %s \n", length(x)),
    names(x),
    "",
    sep = "\n"
  )

  invisible(x)
}

#' Resolve delayed inputs by evaluating the code within the provided datasets
#'
#' `r lifecycle::badge("stable")`
#'
#' @note This is an internal function that is used by [resolve_delayed()].
#' All the methods are used internally only.
#'
#' @param x (`delayed_data`) object to resolve.
#' @param datasets (named `list` of `data.frame`) to use in evaluation.
#' @param keys (named `list` of `character`) to be used as the keys for each dataset.
#' The names of this list must be exactly the same as for datasets.
#'
#' @return Resolved object.
#'
#' @keywords internal
#'
resolve <- function(x, datasets, keys = NULL) {
  checkmate::assert_list(datasets, types = "reactive", min.len = 1, names = "named")
  checkmate::assert_list(keys, "character", names = "named", null.ok = TRUE)
  checkmate::assert(
    .var.name = "keys",
    checkmate::check_names(names(keys), subset.of = names(datasets)),
    checkmate::check_null(keys)
  )


1		# Queue ====
2
3		#' R6 Class - A First-In-First-Out Abstract Data Type
4		#' @docType class
5		#'
6		#' @description
7		#' `r lifecycle::badge("experimental")`
8		#'
9		#' Abstract data type that stores and returns any number of elements.
10		#'
11		#' @details
12		#' A `Queue` object stores all elements in a single vector,
13		#' thus all data types can be stored, but silent coercion may occur.
14		#'
15		#' Elements are returned in the same order that they were added.
16		#'
17		#' @name Queue
18		#' @keywords internal
19		#'
20		Queue <- R6::R6Class( # nolint: object_name_linter.
21		classname = "Queue",
22		# public methods ----
23		public = list(
24		#' @description
25		#' Adds element(s) to `Queue`.
26		#'
27		#' @param new_elements vector of elements to add.
28		#'
29		#' @return `self`, invisibly.
30		#'
31		push = function(new_elements) {
32	11x	for (i in seq_along(new_elements)) {
33		# new_elements[i] does not discard names if it's a named list
34	52x	private$array <- append(private$array, new_elements[i])
35		}
36
37	11x	invisible(self)
38		},
39		#' @description
40		#' Returns all contents of the `Queue` object.
41		#'
42		#' @return Single vector containing all `Queue` contents.
43		#'
44		get = function() {
45	21x	private$array
46		},
47		#' @description
48		#' Returns the first (oldest) element of the `Queue` and removes it.
49		#'
50		#' @return vector of length 1 containing the first element of `Queue`
51		#' or `NULL` if `Queue` is empty.
52		#'
53		pop = function() {
54	1x	returned_element <- self$get()[1L]
55	1x	private$array <- private$array[-1L]
56	1x	returned_element
57		},
58		#' @description
59		#' Removes the oldest occurrence of specified element(s) from `Queue`.
60		#' Relies on implicit type conversions of R identify elements to remove.
61		#'
62		#' @param elements vector of elements to remove from `Queue`.
63		#'
64		#' @return `self`, invisibly.
65		#'
66		remove = function(elements) {
67	7x	for (el in elements) {
68	6x	ind <- Position(function(x) identical(x, el), private$array)
69	5x	if (!is.na(ind)) private$array <- private$array[-ind]
70		}
71	7x	invisible(self)
72		},
73		#' @description
74		#' Removes all elements from `Queue`.
75		#'
76		#' @return `self`, invisibly.
77		#'
78		empty = function() {
79	1x	private$array <- c()
80	1x	invisible(self)
81		},
82		#' @description
83		#' Returns the number of elements in `Queue`.
84		#'
85		#' @return `integer(1)`.
86		#'
87		size = function() {
88	4x	length(self$get())
89		},
90		#' @description
91		#' Prints this `Queue`.
92		#'
93		#' @param ... Additional arguments to this method, ignored.
94		#'
95		#' @return `self`, invisibly.
96		print = function(...) {
97	1x	cat(
98	1x	sprintf(
99	1x	"%s\nSize: %i\nElements:\n%s\n",
100	1x	strsplit(format(self), "\n")[[1]][1],
101	1x	self$size(),
102	1x	paste(self$get(), collapse = " ")
103		)
104		)
105	1x	invisible(self)
106		}
107		),
108
109		# private members ----
110		private = list(
111		array = c()
112		),
113		lock_class = TRUE
114		)

1		#' Include `CSS` files from `/inst/css/` package directory to application header
2		#'
3		#' `system.file` should not be used to access files in other packages, it does
4		#' not work with `devtools`.
5		#' As a result, this method is individually redefined as required in each package.
6		#' Therefore, this function is not exported.
7		#'
8		#' @param pattern (`character`) pattern of files to be included.
9		#'
10		#' @return HTML code that includes `CSS` files.
11		#'
12		#' @keywords internal
13		#'
14		include_css_files <- function(pattern = "*") {
15	1x	css_files <- list.files(
16	1x	system.file("css", package = "teal.transform", mustWork = TRUE),
17	1x	pattern = pattern, full.names = TRUE
18		)
19	1x	singleton(lapply(css_files, includeCSS))
20		}

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	188x	checkmate::assert(
14	188x	checkmate::check_string(varname),
15	188x	checkmate::check_class(varname, "call"),
16	188x	checkmate::check_class(varname, "name")
17		)
18	188x	if (is.character(varname)) {
19	!	parsed <- parse(text = varname, keep.source = FALSE)
20	!	if (length(parsed) == 1) {
21	!	varname <- parsed[[1]]
22		} else {
23	!	stop(
24	!	sprintf(
25	!	"Problem with parsing '%s'. Not able to process multiple calls",
26	!	varname
27		)
28		)
29		}
30		}
31	188x	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	188x	varname <- call_check_parse_varname(varname)
63
64	188x	if (is.factor(choices)) {
65	!	choices <- as.character(choices)
66	188x	} else if (inherits(choices, "Date")) {
67	!	choices <- format(choices)
68	188x	} else if (inherits(choices, c("POSIXct", "POSIXlt"))) {
69	!	choices <- format(choices)
70		}
71
72
73	188x	if (length(choices) == 1) {
74	134x	call("==", varname, choices)
75		} else {
76	54x	c_call <- do.call(
77	54x	"call",
78	54x	append(list("c"), 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	54x	call("%in%", 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	!	checkmate::assert_numeric(range, len = 2, sorted = TRUE)
103
104	!	varname <- call_check_parse_varname(varname)
105	!	call(
106		"&",
107	!	call(">=", varname, range[1]),
108	!	call("<=", varname, 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	!	checkmate::assert_flag(choice)
128	!	varname <- call_check_parse_varname(varname)
129
130	!	if (choice) {
131	!	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	!	checkmate::assert_posixct(range, len = 2, sorted = TRUE)
159	!	checkmate::assert_string(timezone)
160	!	varname <- call_check_parse_varname(varname)
161
162	!	range[1] <- trunc(range[1], units = c("secs"))
163	!	range[2] <- trunc(range[2] + 1, units = c("secs"))
164
165	!	range <- format(
166	!	range,
167	!	format = "%Y-%m-%d %H:%M:%S",
168	!	tz = timezone
169		)
170
171	!	call(
172		"&",
173	!	call(">=", varname, call("as.POSIXct", range[1], tz = timezone)),
174	!	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	!	checkmate::assert_date(range, len = 2)
191	!	checkmate::assert_true(range[2] >= range[1])
192	!	varname <- call_check_parse_varname(varname)
193
194	!	call(
195		"&",
196	!	call(">=", varname, call("as.Date", as.character(range[1]))),
197	!	call("<=", varname, call("as.Date", as.character(range[2])))
198		)
199		}
200
201		#' Get call to subset and select array
202		#'
203		#' @param dataname (`character(1)` or `name`).
204		#' @param row (optional `name` or `call` or `logical` or `integer` or `character`)
205		#' name of the `row` or condition.
206		#' @param column (optional `name` or `call` or `logical`, `integer` or `character`)
207		#' name of the `column` or condition.
208		#' @param aisle (optional `name` or `call` or `logical` or `integer` or `character`)
209		#' name of the `row` or condition.
210		#'
211		#' @return [Extract()] `call` for 3-dimensional array in `x[i, j, k]` notation.
212		#'
213		#' @keywords internal
214		#'
215		call_extract_array <- function(dataname = ".", row = NULL, column = NULL, aisle = NULL) {
216	!	checkmate::assert(
217	!	checkmate::check_string(dataname),
218	!	checkmate::check_class(dataname, "call"),
219	!	checkmate::check_class(dataname, "name")
220		)
221	!	stopifnot(is.null(row) \|\| is.call(row) \|\| is.character(row) \|\| is.logical(row) \|\| is.integer(row) \|\| is.name(row))
222	!	stopifnot(is.null(column) \|\| is.call(column) \|\| is.vector(column) \|\| is.name(column))
223	!	stopifnot(is.null(aisle) \|\| is.call(aisle) \|\| is.vector(aisle) \|\| is.name(aisle))
224
225	!	if (is.language(dataname)) {
226	!	dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n")
227		}
228
229	!	row <- if (is.null(row)) {
230		""
231		} else {
232	!	paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n")
233		}
234	!	column <- if (is.null(column)) {
235		""
236		} else {
237	!	paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n")
238		}
239	!	aisle <- if (is.null(aisle)) {
240		""
241		} else {
242	!	paste(trimws(deparse(aisle, width.cutoff = 500L)), collapse = "\n")
243		}
244
245	!	parse(
246	!	text = sprintf("%s[%s, %s, %s]", dataname, row, column, aisle),
247	!	keep.source = FALSE
248	!	)[[1]]
249		}
250
251		#' Get call to subset and select matrix
252		#'
253		#' @param dataname (`character(1)` or `name`).
254		#' @param row (optional `name` or `call` or `logical` or `integer` or `character`)
255		#' name of the `row` or condition.
256		#' @param column (optional `name` or `call` or `logical` or `integer` or `character`)
257		#' name of the `column` or condition.
258		#'
259		#' @return [Extract()] `call` for matrix in `x[i, j]` notation.
260		#'
261		#' @keywords internal
262		#'
263		call_extract_matrix <- function(dataname = ".", row = NULL, column = NULL) {
264	!	checkmate::assert(
265	!	checkmate::check_string(dataname),
266	!	checkmate::check_class(dataname, "call"),
267	!	checkmate::check_class(dataname, "name")
268		)
269	!	stopifnot(is.null(row) \|\| is.call(row) \|\| is.character(row) \|\| is.logical(row) \|\| is.integer(row) \|\| is.name(row))
270	!	stopifnot(is.null(column) \|\| is.call(column) \|\| is.vector(column) \|\| is.name(column))
271
272	!	if (is.language(dataname)) {
273	!	dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n")
274		}
275
276	!	row <- if (is.null(row)) {
277		""
278		} else {
279	!	paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n")
280		}
281	!	column <- if (is.null(column)) {
282		""
283		} else {
284	!	paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n")
285		}
286
287	!	parse(
288	!	text = sprintf("%s[%s, %s]", dataname, row, column),
289	!	keep.source = FALSE
290	!	)[[1]]
291		}
292
293
294		#' Compose extract call with `$` operator
295		#'
296		#' @param dataname (`character(1)` or `name`) name of the object.
297		#' @param varname (`character(1)` or `name`) name of the slot in data.
298		#' @param dollar (`logical(1)`) whether returned call should use `$` or `[[` operator.
299		#'
300		#' @return [Extract()] `call` in `$` or `[[` notation (depending on parameters).
301		#'
302		#' @keywords internal
303		#'
304		call_extract_list <- function(dataname, varname, dollar = TRUE) {
305	!	checkmate::assert_flag(dollar)
306	!	checkmate::assert(
307	!	checkmate::check_string(varname),
308	!	checkmate::check_class(varname, "name"),
309	!	checkmate::assert(
310	!	combine = "and",
311	!	checkmate::check_class(varname, "call"),
312	!	checkmate::check_false(dollar)
313		)
314		)
315
316	!	dataname <- call_check_parse_varname(dataname)
317
318	!	if (dollar) {
319	!	call("$", dataname, varname)
320		} else {
321	!	call("[[", dataname, varname)
322		}
323		}
324
325		#' Create a call using a function in a given namespace
326		#'
327		#' The dot arguments in `...` need to be quoted because they will be evaluated otherwise.
328		#'
329		#' @param name `character` function name, possibly using namespace colon `::`, also
330		#' works with `:::` (sometimes needed, but strongly discouraged).
331		#' @param ... arguments to pass to function with name `name`.
332		#' @param unlist_args `list` extra arguments passed in a single list,
333		#' avoids the use of `do.call` with this function.
334		#'
335		#' @return `call`.
336		#'
337		#' @keywords internal
338		#'
339		call_with_colon <- function(name, ..., unlist_args = list()) {
340	!	checkmate::assert_string(name)
341	!	checkmate::assert_list(unlist_args)
342	!	as.call(c(
343	!	parse(text = name, keep.source = FALSE)[[1]],
344	!	c(list(...), unlist_args)
345		))
346		}
347
348
349		#' Combine calls by operator
350		#'
351		#' Combine list of calls by specific operator.
352		#'
353		#' @param operator (`character(1)` or `name`) name / symbol of the operator.
354		#' @param calls (`list` of calls) list containing calls to be combined by `operator`.
355		#'
356		#' @return A combined `call`.
357		#'
358		#' @keywords internal
359		#'
360		calls_combine_by <- function(operator, calls) {
361	98x	checkmate::assert_string(operator)
362	98x	stopifnot(
363	98x	all(
364	98x	vapply(
365	98x	X = calls,
366	98x	FUN.VALUE = logical(1),
367	98x	FUN = function(x) is.language(x) \|\| is.logical(x)
368		)
369		)
370		)
371
372	98x	Reduce(
373	98x	x = calls,
374	98x	f = function(x, y) call(operator, x, y)
375		)
376		}

1		no_select_keyword <- "-- no selection --"
2
3		#' Choices selected
4		#'
5		#' @description
6		#' `r lifecycle::badge("stable")`
7		#'
8		#' Construct a single list containing available choices, the default selected value, and
9		#' additional settings such as to order the choices with the selected elements appearing first
10		#' or whether to block the user from making selections.
11		#'
12		#' Can be used in UI input elements such as [teal.widgets::optionalSelectInput()].
13		#'
14		#' @details
15		#' Please note that the order of selected will always follow the order of choices. The `keep_order`
16		#' argument is set to false which will run the following code inside:
17		#'
18		#' ```
19		#' choices <- c(selected, setdiff(choices, selected))
20		#' ```
21		#'
22		#' In case you want to keep your specific order of choices, set `keep_order` to `TRUE`.
23		#'
24		#' @param choices (`character`) vector of possible choices or `delayed_data` object.
25		#'
26		#' See [variable_choices()] and [value_choices()].
27		#' @param selected (`character`) vector of preselected options, (`all_choices`) object
28		#' or (`delayed_data`) object.
29		#'
30		#' If `delayed_data` object then `choices` must also be `delayed_data` object.
31		#' If not supplied it will default to the first element of `choices` if
32		#' `choices` is a vector, or `NULL` if `choices` is a `delayed_data` object.
33		#' @param keep_order (`logical`) In case of `FALSE` the selected variables will
34		#' be on top of the drop-down field.
35		#' @param fixed (optional `logical`) Whether to block user to select choices.
36		#'
37		#' @return `choices_selected` returns list of `choices_selected`, encapsulating the specified
38		#' `choices`, `selected`, `keep_order` and `fixed`.
39		#'
40		#' @examples
41		#' library(shiny)
42		#' library(teal.widgets)
43		#'
44		#' # all_choices example - semantically the same objects
45		#' choices_selected(choices = letters, selected = all_choices())
46		#' choices_selected(choices = letters, selected = letters)
47		#'
48		#' choices_selected(
49		#' choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])),
50		#' selected = "C"
51		#' )
52		#'
53		#' ADSL <- teal.transform::rADSL
54		#' choices_selected(variable_choices(ADSL), "SEX")
55		#'
56		#' # How to select nothing
57		#' # use an empty character
58		#' choices_selected(
59		#' choices = c("", "A", "B", "C"),
60		#' selected = ""
61		#' )
62		#'
63		#' # How to allow the user to select nothing
64		#' # use an empty character
65		#' choices_selected(
66		#' choices = c("A", "", "B", "C"),
67		#' selected = "A"
68		#' )
69		#'
70		#'
71		#' # How to make Nothing the Xth choice
72		#' # just use keep_order
73		#' choices_selected(
74		#' choices = c("A", "", "B", "C"),
75		#' selected = "A",
76		#' keep_order = TRUE
77		#' )
78		#'
79		#'
80		#' # How to give labels to selections
81		#' # by adding names - choices will be replaced by "name" in UI, not in code
82		#' choices_selected(
83		#' choices = c("name for A" = "A", "Name for nothing" = "", "name for b" = "B", "name for C" = "C"),
84		#' selected = "A"
85		#' )
86		#'
87		#' # by using choices_labeled
88		#' # labels will be shown behind the choice
89		#' choices_selected(
90		#' choices = choices_labeled(
91		#' c("A", "", "B", "C"),
92		#' c("name for A", "nothing", "name for B", "name for C")
93		#' ),
94		#' selected = "A"
95		#' )
96		#'
97		#' # Passing a `delayed_data` object to `selected`
98		#' choices_selected(
99		#' choices = variable_choices("ADSL"),
100		#' selected = variable_choices("ADSL", subset = c("STUDYID"))
101		#' )
102		#'
103		#' # functional form (subsetting for factor variables only) of choices_selected
104		#' # with delayed data loading
105		#' choices_selected(variable_choices("ADSL", subset = function(data) {
106		#' idx <- vapply(data, is.factor, logical(1))
107		#' names(data)[idx]
108		#' }))
109		#'
110		#' cs <- choices_selected(
111		#' choices = c("A", "B", "C"),
112		#' selected = "A"
113		#' )
114		#'
115		#' ui <- fluidPage(
116		#' optionalSelectInput(
117		#' inputId = "id",
118		#' choices = cs$choices,
119		#' selected = cs$selected
120		#' )
121		#' )
122		#'
123		#' server <- function(input, output, session) {}
124		#' if (interactive()) {
125		#' shinyApp(ui, server)
126		#' }
127		#' @export
128		#'
129		choices_selected <- function(choices,
130		selected = if (inherits(choices, "delayed_data")) NULL else choices[1],
131		keep_order = FALSE,
132		fixed = FALSE) {
133	32x	checkmate::assert(
134	32x	checkmate::check_atomic(choices),
135	32x	checkmate::check_class(choices, "delayed_data")
136		)
137	32x	checkmate::assert(
138	32x	checkmate::check_atomic(selected),
139	32x	checkmate::check_multi_class(selected, c("delayed_data", "all_choices"))
140		)
141	32x	checkmate::assert_flag(keep_order)
142	32x	checkmate::assert_flag(fixed)
143
144	1x	if (inherits(selected, "all_choices")) selected <- choices
145
146	32x	if (inherits(selected, "delayed_data") && !inherits(choices, "delayed_data")) {
147	1x	stop("If 'selected' is of class 'delayed_data', so must be 'choices'.")
148		}
149
150	31x	if (inherits(choices, "delayed_data")) {
151	11x	return(
152	11x	structure(
153	11x	list(choices = choices, selected = selected, keep_order = keep_order, fixed = fixed),
154	11x	class = c("delayed_choices_selected", "delayed_data", "choices_selected")
155		)
156		)
157		}
158
159	20x	if (!is.null(choices) && no_select_keyword %in% choices) {
160	1x	stop(paste(no_select_keyword, "is not a valid choice as it is used as a keyword"))
161		}
162
163		# remove duplicates
164	19x	choices <- vector_remove_dups(choices)
165	19x	selected <- vector_remove_dups(selected)
166	19x	checkmate::assert_subset(selected, choices)
167
168	16x	if (!keep_order && length(choices) > 0) {
169	16x	choices_in_selected <- which(choices %in% selected)
170	16x	choices <- vector_reorder(
171	16x	choices,
172	16x	c(choices_in_selected, setdiff(seq_along(choices), choices_in_selected))
173		)
174		}
175
176	16x	structure(
177	16x	list(
178	16x	choices = choices,
179	16x	selected = selected,
180	16x	fixed = fixed
181		),
182	16x	class = "choices_selected"
183		)
184		}
185
186		#' @describeIn choices_selected Check if an object is a choices_selected class
187		#'
188		#' @param x (`choices_selected`) object to check.
189		#'
190		#' @return `is.choices_selected` returns `TRUE` if `x` inherits from a `choices_selected` object, `FALSE` otherwise.
191		#'
192		#' @export
193		#'
194		is.choices_selected <- function(x) { # nolint: object_name_linter.
195	24x	inherits(x, "choices_selected")
196		}
197
198		#' Add empty choice to choices selected
199		#'
200		#' `r lifecycle::badge("stable")`
201		#'
202		#' @param x (`choices_selected`) object.
203		#' @param multiple (`logical(1)`) whether multiple selections are allowed or not.
204		#'
205		#' @return `choices_selected` object with an empty option added to the choices.
206		#'
207		#' @export
208		#'
209		add_no_selected_choices <- function(x, multiple = FALSE) {
210	!	if (is.null(x)) {
211	!	choices_selected(NULL)
212		} else {
213	!	stopifnot(is.choices_selected(x))
214
215	!	if (!multiple) {
216	!	x$choices <- c(no_select_keyword, x$choices)
217	!	if (is.null(x$selected)) x$selected <- no_select_keyword
218		}
219
220	!	x
221		}
222		}
223
224		#' Check select choices for no choice made
225		#'
226		#' `r lifecycle::badge("stable")`
227		#'
228		#' @param x (`character`) Word that shall be checked for `NULL`, empty, "--no-selection".
229		#'
230		#' @return The word or `NULL`.
231		#'
232		#' @export
233		#'
234		no_selected_as_NULL <- function(x) { # nolint: object_name_linter.
235	!	if (is.null(x) \|\| identical(x, no_select_keyword) \|\| x == "") {
236	!	NULL
237		} else {
238	!	x
239		}
240		}
241
242		## Non-exported utils functions ----
243		#' Modify vectors and keep attributes
244		#' @keywords internal
245		#' @noRd
246		#'
247		vector_reorder <- function(vec, idx) {
248	16x	checkmate::assert_atomic(vec)
249	16x	checkmate::assert_integer(idx, min.len = 1, lower = 1, any.missing = FALSE)
250	16x	stopifnot(length(vec) == length(idx))
251
252	16x	vec_attrs <- attributes(vec)
253
254	16x	vec <- vec[idx]
255
256	16x	for (vec_attrs_idx in seq_along(vec_attrs)) {
257	43x	if (length(vec_attrs[[vec_attrs_idx]]) == length(vec)) {
258	42x	vec_attrs[[vec_attrs_idx]] <- vec_attrs[[vec_attrs_idx]][idx]
259		}
260		}
261
262	16x	attributes(vec) <- vec_attrs
263	16x	vec
264		}
265
266		#' Remove item(s) and their attributes from vector
267		#' @keywords internal
268		#' @noRd
269		#'
270		vector_pop <- function(vec, idx) {
271	1x	checkmate::assert_atomic(vec)
272	1x	checkmate::assert_integer(idx, lower = 1, any.missing = FALSE)
273
274	1x	if (length(idx) == 0) {
275	!	return(vec)
276		}
277
278	1x	vec_attrs <- attributes(vec)
279	1x	names_vec_attrs <- names(vec_attrs)
280
281	1x	for (vec_attrs_idx in seq_along(vec_attrs)) {
282	4x	if (length(vec_attrs[[vec_attrs_idx]]) == length(vec) && names_vec_attrs[vec_attrs_idx] != "class") {
283	3x	vec_attrs[[vec_attrs_idx]] <- vec_attrs[[vec_attrs_idx]][-idx]
284		}
285		}
286
287	1x	vec <- vec[-idx]
288	1x	attributes(vec) <- vec_attrs
289	1x	vec
290		}
291
292		#' Remove duplicate elements or elements with the same name from a vector
293		#' @keywords internal
294		#' @noRd
295		#'
296		vector_remove_dups <- function(vec) {
297	38x	checkmate::assert_atomic(vec)
298
299	38x	idx <- which(duplicated(vec))
300
301	38x	if (length(idx) == 0) {
302	33x	vec
303	5x	} else if (is.null(attributes(vec))) {
304	2x	unique(vec)
305	3x	} else if (identical(names(attributes(vec)), "names")) {
306	2x	vec[-idx]
307		} else {
308	1x	vector_pop(vec, idx)
309		}
310		}

1		#' Aggregates data extract selectors
2		#'
3		#' Simplifies `selector_list` into aggregated list with one element per
4		#' same selector - same dataset, same filter configuration and same reshape status.
5		#'
6		#' @inheritParams get_merge_call
7		#'
8		#' @return (`list`) simplified selectors with aggregated set of filters,
9		#' selections, reshapes etc. All necessary data for merging.
10		#'
11		#' @keywords internal
12		#'
13		get_dplyr_call_data <- function(selector_list, join_keys = teal.data::join_keys()) {
14	163x	logger::log_trace("get_dplyr_call_data called with: { paste(names(selector_list), collapse = ', ') } selectors.")
15	163x	checkmate::assert_class(join_keys, "join_keys")
16	163x	lapply(selector_list, check_selector)
17
18	163x	all_merge_key_list <- get_merge_key_grid(selector_list, join_keys)
19	163x	res <- lapply(
20	163x	seq_along(selector_list),
21	163x	function(idx) {
22	361x	internal_id <- selector_list[[idx]]$internal_id
23
24	361x	merge_keys_list <- all_merge_key_list[[idx]]
25
26	361x	merge_keys <- if (length(merge_keys_list) > 1) {
27	328x	unique(unlist(lapply(merge_keys_list[-idx], names)))
28		} else {
29	33x	names(merge_keys_list[[1]])
30		}
31
32	361x	if (isFALSE(selector_list[[idx]]$reshape)) {
33	272x	unite_cols <- character(0)
34	272x	pivot_longer_cols <- character(0)
35	272x	unite_vals <- character(0)
36		} else {
37	89x	unite_cols <- get_reshape_unite_col(selector_list[[idx]])
38	89x	pivot_longer_cols <- get_pivot_longer_col(selector_list[[idx]])
39	89x	unite_vals <- get_reshape_unite_vals(selector_list[[idx]])
40		}
41
42	361x	selector_cols <- c(selector_list[[idx]]$select)
43	361x	init_select_cols <- unique(c(pivot_longer_cols, selector_cols))
44	361x	init_select_cols_with_keys <- unique(c(merge_keys, unite_cols, pivot_longer_cols, selector_cols))
45		# can change order of keys
46
47	361x	list(
48	361x	internal_id = internal_id,
49	361x	merge_keys_list = merge_keys_list,
50	361x	unite_cols = unite_cols,
51	361x	unite_vals = unite_vals,
52	361x	pivot_longer_cols = pivot_longer_cols,
53	361x	selector_cols = selector_cols,
54	361x	init_select_cols_with_keys = init_select_cols_with_keys,
55	361x	init_select_cols = init_select_cols
56		)
57		}
58		)
59
60		# rename duplicated non-key columns
61	163x	all_cols <- unlist(lapply(res, `[[`, "init_select_cols"))
62	163x	for (idx1 in seq_along(res)) {
63	361x	init_select_cols <- res[[idx1]]$init_select_cols
64	361x	internal_id <- res[[idx1]]$internal_id
65	361x	selector_cols <- res[[idx1]]$selector_cols
66	361x	unite_cols <- res[[idx1]]$unite_cols
67	361x	unite_vals <- res[[idx1]]$unite_vals
68	361x	pivot_longer_cols <- res[[idx1]]$pivot_longer_cols
69	361x	merge_keys <- unique(unlist(res[[idx1]]$merge_keys_list))
70
71	361x	init_select_cols_renamed <- rename_duplicated_cols(
72	361x	setdiff(init_select_cols, merge_keys),
73	361x	internal_id,
74	361x	setdiff(selector_cols, unite_cols),
75	361x	all_cols
76		)
77
78	361x	pivot_longer_cols_renamed <- rename_duplicated_cols(
79	361x	pivot_longer_cols,
80	361x	internal_id,
81	361x	setdiff(selector_cols, unite_cols),
82	361x	all_cols
83		)
84
85	361x	pivot_longer_unite_cols_renamed <- if (rlang::is_empty(unite_vals)) { # nolint: object_length_linter.
86	278x	pivot_longer_cols_renamed
87		} else {
88	83x	Reduce(
89	83x	append,
90	83x	mapply(
91	83x	function(x1, name) {
92	114x	stats::setNames(paste(x1, unite_vals, sep = "_"), rep(name, length(unite_vals)))
93		},
94	83x	x1 = pivot_longer_cols_renamed,
95	83x	name = pivot_longer_cols,
96	83x	SIMPLIFY = FALSE,
97	83x	USE.NAMES = FALSE
98		)
99		)
100		}
101
102	361x	selector_cols_renamed <- rename_duplicated_cols(
103	361x	init_select_cols,
104	361x	internal_id,
105	361x	setdiff(selector_cols, unite_cols),
106	361x	all_cols[!all_cols %in% merge_keys]
107		)
108
109	361x	out_cols_renamed <- if (!rlang::is_empty(pivot_longer_unite_cols_renamed)) {
110	86x	pivot_longer_unite_cols_renamed
111		} else {
112	275x	selector_cols_renamed
113		}
114
115	361x	res[[idx1]]$init_select_cols_renamed <- init_select_cols_renamed
116	361x	res[[idx1]]$pivot_longer_cols_renamed <- pivot_longer_cols_renamed
117	361x	res[[idx1]]$out_cols_renamed <- out_cols_renamed
118		}
119	163x	res
120		}
121
122		#' Parses filter, select, rename and reshape call
123		#'
124		#' @inheritParams get_dplyr_call_data
125		#'
126		#' @param idx optional (`integer`) current selector index in all selectors list.
127		#' @param dplyr_call_data (`list`) simplified selectors with aggregated set of filters,
128		#' selections, reshapes etc. All necessary data for merging.
129		#' @param data (`NULL` or named `list`) of datasets.
130		#'
131		#' @return (`call`) filter, select, rename and reshape call.
132		#'
133		#' @keywords internal
134		#'
135		get_dplyr_call <- function(selector_list,
136		idx = 1L,
137		join_keys = teal.data::join_keys(),
138		dplyr_call_data = get_dplyr_call_data(selector_list, join_keys = join_keys),
139		datasets = NULL) {
140	121x	logger::log_trace(
141	121x	paste(
142	121x	"get_dplyr_call called with:",
143	121x	"{ paste(names(datasets), collapse = ', ') } datasets;",
144	121x	"{ paste(names(selector_list), collapse = ', ') } selectors."
145		)
146		)
147	121x	lapply(selector_list, check_selector)
148	121x	checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)
149	121x	checkmate::assert_integer(idx, len = 1, any.missing = FALSE)
150
151	121x	n_selectors <- length(selector_list)
152
153	121x	dataname_filtered <- as.name(selector_list[[idx]]$dataname)
154
155	121x	filter_call <- get_filter_call(selector_list[[idx]]$filters, selector_list[[idx]]$dataname, datasets)
156
157	121x	select_call <- get_select_call(dplyr_call_data[[idx]]$init_select_cols_with_keys)
158
159	121x	rename_call <- if (n_selectors > 1) {
160	90x	get_rename_call(dplyr_call_data = dplyr_call_data, idx = idx)
161		} else {
162	31x	NULL
163		}
164
165	121x	reshape_call <- if (isTRUE(selector_list[[idx]]$reshape)) {
166	29x	get_reshape_call(dplyr_call_data = dplyr_call_data, idx = idx)
167		} else {
168	92x	NULL
169		}
170
171	121x	Reduce(
172	121x	function(x, y) call("%>%", x, y),
173	121x	Filter(function(x) !is.null(x), c(dataname_filtered, filter_call, select_call, rename_call, reshape_call))
174		)
175		}
176
177		#' Parse `dplyr` select call
178		#'
179		#' @param select (`character`) vector of selected column names.
180		#'
181		#' @return `dplyr` select `call`.
182		#'
183		#' @keywords internal
184		#'
185		get_select_call <- function(select) {
186	124x	logger::log_trace("get_select_call called with: { paste(select, collapse = ', ') } columns.")
187	124x	if (is.null(select) \|\| length(select) == 0) {
188	1x	return(NULL)
189		}
190
191	123x	select <- unique(select)
192
193	123x	as.call(c(list(quote(dplyr::select)), lapply(select, as.name)))
194		}
195
196		#' Build a `dplyr` filter call
197		#'
198		#' @param filter (`list`) Either list of lists or list with `select` and `selected` items.
199		#' @param dataname (`NULL` or `character`) name of dataset.
200		#' @param datasets (`NULL` or named `list`).
201		#'
202		#' @return `dplyr` filter `call`.
203		#'
204		#' @keywords internal
205		#'
206		get_filter_call <- function(filter, dataname = NULL, datasets = NULL) {
207	142x	logger::log_trace(
208	142x	paste(
209	142x	"get_filter_call called with:",
210	142x	"{ dataname } dataset;",
211	142x	"{ paste(sapply(filter, function(x) x$columns), collapse = ', ') } filters."
212		)
213		)
214	142x	checkmate::assert_list(datasets, types = "reactive", names = "named", null.ok = TRUE)
215	141x	if (is.null(filter)) {
216	38x	return(NULL)
217		}
218
219	103x	stopifnot(
220	103x	(!is.null(dataname) && is.null(datasets)) \|\|
221	103x	(is.null(dataname) && is.null(datasets)) \|\|
222	103x	(!is.null(datasets) && isTRUE(dataname %in% names(datasets)))
223		)
224
225	103x	get_filter_call_internal <- function(filter, dataname, datasets) {
226	161x	if (rlang::is_empty(filter$selected)) {
227	2x	return(FALSE)
228		}
229
230	159x	keys <- filter$columns
231	159x	datas_vars <- if (!is.null(datasets)) datasets[[dataname]]() else NULL
232
233	159x	if (!is.null(datas_vars)) {
234	17x	u_variables <- unique(apply(datas_vars[, keys, drop = FALSE], 1, function(x) paste(x, collapse = "-")))
235	17x	selected <- if (length(keys) == 1) {
236	11x	selected_single <- unlist(filter$selected)
237		# We need character NA as for rest vars the NA is translated to "NA" by paste function
238	11x	selected_single[is.na(selected_single)] <- "NA"
239	11x	selected_single
240		} else {
241	6x	unlist(lapply(filter$selected, function(x) paste(x, collapse = "-")))
242		}
243		# we don't want to process the key which all values are selected
244		# this means that call for this key is redundant and will be skipped
245	17x	if (all(u_variables %in% selected)) {
246	6x	keys <- NULL
247		}
248		}
249
250	159x	if (length(keys) == 1) {
251	135x	key_name <- unlist(keys)
252	135x	key_value <- unlist(filter$selected)
253	135x	varname <- if (isTRUE(inherits(datas_vars[[key_name]], c("POSIXct", "POSIXlt", "POSIXt")))) {
254	1x	bquote(trunc(.(as.name(key_name))))
255		} else {
256	134x	as.name(key_name)
257		}
258
259	135x	if (length(key_value) == 1 && is.na(key_value)) {
260	1x	call("is.na", as.name(key_name))
261		} else {
262	134x	call_condition_choice(varname = varname, choices = key_value)
263		}
264	24x	} else if (length(keys) > 1) {
265	18x	calls_combine_by(
266		"\|",
267	18x	lapply(
268	18x	filter$selected,
269	18x	function(keys_values) {
270	27x	res <- calls_combine_by(
271		"&",
272	27x	Map(
273	27x	keys,
274	27x	keys_values,
275	27x	f = function(key_name, key_value) {
276	60x	if (is.na(key_value)) {
277	6x	call("is.na", as.name(key_name))
278		} else {
279	54x	varname <- if (isTRUE(inherits(datas_vars[[key_name]], c("POSIXct", "POSIXlt", "POSIXt")))) {
280	2x	bquote(trunc(.(as.name(key_name))))
281		} else {
282	52x	as.name(key_name)
283		}
284
285	54x	call_condition_choice(
286	54x	varname = varname,
287	54x	key_value
288		)
289		}
290		}
291		)
292		)
293	27x	call("(", res)
294		}
295		)
296		)
297		}
298		}
299
300	103x	internal <- if (length(filter) == 1) {
301	50x	get_filter_call_internal(filter[[1]], dataname, datasets)
302		} else {
303	53x	res <- Filter(Negate(is.null), Map(function(x) get_filter_call_internal(x, dataname, datasets), filter))
304	53x	calls_combine_by("&", res)
305		}
306
307
308	103x	if (!is.null(internal)) {
309	98x	as.call(c(quote(dplyr::filter), internal))
310		} else {
311	5x	NULL
312		}
313		}
314
315		#' Remove duplicated columns
316		#' @keywords internal
317		#' @noRd
318		#'
319		rename_duplicated_cols <- function(x, internal_id, selected_cols, all_cols) {
320	1083x	all_cols_dups <- all_cols[duplicated(all_cols)]
321	1083x	vapply(
322	1083x	x,
323	1083x	function(y) {
324	1538x	ifelse(y %in% selected_cols && y %in% all_cols_dups, paste0(internal_id, ".", y), y)
325		},
326	1083x	character(1)
327		)
328		}
329
330		#' Returns `dplyr` rename call
331		#'
332		#' Rename is used only if there are duplicated columns.
333		#'
334		#' @inheritParams get_dplyr_call
335		#'
336		#' @return (`call`) `dplyr` rename call.
337		#'
338		#' @keywords internal
339		#'
340		get_rename_call <- function(selector_list = list(),
341		idx = 1L,
342		join_keys = teal.data::join_keys(),
343		dplyr_call_data = get_dplyr_call_data(selector_list, join_keys = join_keys)) {
344	94x	checkmate::assert_integer(idx, len = 1, any.missing = FALSE)
345	94x	stopifnot(length(dplyr_call_data) >= idx)
346	94x	logger::log_trace(
347	94x	paste(
348	94x	"get_rename_call called with:",
349	94x	"{ dplyr_call_data[[idx]]$internal_id } selector;",
350	94x	"{ paste(dplyr_call_data[[idx]]$init_select_cols_renamed, collapse = ', ') } renamed columns."
351		)
352		)
353
354	94x	lapply(selector_list, check_selector)
355
356	94x	rename_dict <- dplyr_call_data[[idx]]$init_select_cols_renamed
357	94x	rename_dict <- rename_dict[names(rename_dict) != rename_dict]
358
359	94x	if (is.null(rename_dict) \|\| length(rename_dict) == 0) {
360	16x	return(NULL)
361		}
362
363	78x	internal <- stats::setNames(lapply(names(rename_dict), as.name), rename_dict)
364
365	78x	as.call(append(quote(dplyr::rename), internal))
366		}
367
368		#' Returns `dplyr` reshape call
369		#'
370		#' @inheritParams get_dplyr_call
371		#'
372		#' @return List of multiple `dplyr` calls that reshape data.
373		#'
374		#' @keywords internal
375		#'
376		get_reshape_call <- function(selector_list = list(),
377		idx = 1L,
378		join_keys = teal.data::join_keys(),
379		dplyr_call_data = get_dplyr_call_data(selector_list, join_keys = join_keys)) {
380	31x	checkmate::assert_integer(idx, len = 1, any.missing = FALSE)
381	31x	stopifnot(length(dplyr_call_data) >= idx)
382	31x	logger::log_trace(
383	31x	paste(
384	31x	"get_reshape_call called with:",
385	31x	"{ dplyr_call_data[[idx]]$internal_id } selector;",
386	31x	"{ paste(dplyr_call_data[[idx]]$unite_cols, collapse = ', ') } reshaping columns;",
387	31x	"{ paste(dplyr_call_data[[idx]]$pivot_longer_cols, collapse = ', ') } reshaped columns."
388		)
389		)
390	31x	lapply(selector_list, check_selector)
391
392	31x	pl_cols <- unname(dplyr_call_data[[idx]]$pivot_longer_cols_renamed)
393
394	31x	pivot_longer_call <- as.call(list(
395	31x	quote(tidyr::pivot_longer),
396	31x	cols = if (length(pl_cols)) pl_cols else quote(tidyselect::everything()),
397	31x	names_to = "MEASURE",
398	31x	values_to = "VALUE"
399		))
400
401	31x	unite_call <- as.call(c(
402	31x	list(quote(tidyr::unite)),
403	31x	quote(KEY),
404	31x	quote(MEASURE),
405	31x	lapply(
406	31x	dplyr_call_data[[idx]]$unite_cols,
407	31x	function(x) {
408	49x	as.name(x)
409		}
410		)
411		))
412
413	31x	pivot_wider_call <- as.call(list(
414	31x	quote(tidyr::pivot_wider),
415	31x	names_from = "KEY",
416	31x	values_from = "VALUE"
417		))
418
419	31x	c(pivot_longer_call, unite_call, pivot_wider_call)
420		}
421
422
423		#' Get pivot longer columns
424		#'
425		#' Get values names which are spread into columns.
426		#'
427		#' @param selector one element of selector_list obtained by `get_dplyr_call_data`.
428		#'
429		#' @return A `character` vector of all the selected columns that are not a `keys` element.
430		#'
431		#' @keywords internal
432		#'
433		get_pivot_longer_col <- function(selector) {
434	89x	logger::log_trace("get_reshape_unite_col called with: { selector$internal_id } selector.")
435	89x	setdiff(selector$select, selector$keys)
436		}
437
438		#' Get unite columns
439		#'
440		#' Get key names which spreads values into columns. Reshape is done only
441		#' on keys which are in `filter_spec`.
442		#'
443		#' @inheritParams get_pivot_longer_col
444		#'
445		#' @return A `character` vector of all the selector's keys that are defined in the filters.
446		#'
447		#' @keywords internal
448		#'
449		get_reshape_unite_col <- function(selector) {
450	379x	logger::log_trace("get_reshape_unite_col called with: { selector$internal_id } selector.")
451	379x	intersect(
452	379x	selector$keys,
453	379x	unlist(lapply(selector$filters, `[[`, "columns"))
454		)
455		}
456
457		#' Get unite columns values
458		#'
459		#' Get key values (levels) of the unite columns.
460		#'
461		#' @inheritParams get_pivot_longer_col
462		#'
463		#' @return A `character` vector of keys of the unite columns.
464		#'
465		#' @keywords internal
466		#'
467		get_reshape_unite_vals <- function(selector) {
468	123x	logger::log_trace("get_reshape_unite_vals called with: { selector$internal_id } selector.")
469	123x	unite_cols <- get_reshape_unite_col(selector)
470	123x	filters <- selector$filters
471	123x	filters_columns <- lapply(filters, `[[`, "columns")
472
473		# first check if combined filter exists then check one by one
474	123x	filters_idx <- which(vapply(filters_columns, function(x) identical(unite_cols, x), logical(1)))
475	123x	if (length(filters_idx) == 0) {
476	70x	filters_idx <- which(filters_columns %in% unite_cols)
477		}
478
479	123x	unite_cols_vals <- lapply(
480	123x	filters[filters_idx],
481	123x	function(x) {
482	175x	vapply(x$selected, paste, character(1), collapse = "_")
483		}
484		)
485	123x	unite_cols_vals <- unite_cols_vals[vapply(unite_cols_vals, length, integer(1)) > 0]
486
487	123x	if (length(unite_cols_vals) > 0) {
488	114x	grid <- do.call(expand.grid, args = list(unite_cols_vals, stringsAsFactors = FALSE))
489	114x	apply(grid, 1, paste, collapse = "_")
490		} else {
491	9x	character(0)
492		}
493		}

1		#' Merge the datasets on the keys
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' Combines/merges multiple datasets with specified keys attribute.
7		#'
8		#' @details
9		#' Internally this function uses calls to allow reproducibility.
10		#'
11		#' This function is often used inside a `teal` module server function with the
12		#' `selectors` being the output of `data_extract_srv` or `data_extract_multiple_srv`.
13		#'
14		#' ```
15		#' # inside teal module server function
16		#'
17		#' response <- data_extract_srv(
18		#' id = "reponse",
19		#' data_extract_spec = response_spec,
20		#' datasets = datasets
21		#' )
22		#' regressor <- data_extract_srv(
23		#' id = "regressor",
24		#' data_extract_spec = regressor_spec,
25		#' datasets = datasets
26		#' )
27		#' merged_data <- merge_datasets(list(regressor(), response()))
28		#' ```
29		#'
30		#' @inheritParams merge_expression_srv
31		#'
32		#' @return `merged_dataset` list containing:
33		#' * `expr` (`list` of `call`) code needed to replicate merged dataset;
34		#' * `columns_source` (`list`) of column names selected for particular selector;
35		#' Each list element contains named character vector where:
36		#' * Values are the names of the columns in the `ANL`. In case if the same column name is selected in more than one
37		#' selector it gets prefixed by the id of the selector. For example if two `data_extract` have id `x`, `y`, then
38		#' their duplicated selected variable (for example `AGE`) is prefixed to be `x.AGE` and `y.AGE`;
39		#' * Names of the vector denote names of the variables in the input dataset;
40		#' * `attr(,"dataname")` to indicate which dataset variable is merged from;
41		#' * `attr(, "always selected")` to denote the names of the variables which need to be always selected;
42		#' * `keys` (`list`) the keys of the merged dataset;
43		#' * `filter_info` (`list`) The information given by the user. This information
44		#' defines the filters that are applied on the data. Additionally it defines
45		#' the variables that are selected from the data sets.
46		#'
47		#' @examples
48		#' library(shiny)
49		#' library(teal.data)
50		#'
51		#' X <- data.frame(A = c(1, 1:3), B = 2:5, D = 1:4, E = letters[1:4], G = letters[6:9])
52		#' Y <- data.frame(A = c(1, 1, 2), B = 2:4, C = c(4, 4:5), E = letters[4:6], G = letters[1:3])
53		#' join_keys <- join_keys(join_key("X", "Y", c("A", "B")))
54		#'
55		#' selector_list <- list(
56		#' list(
57		#' dataname = "X",
58		#' filters = NULL,
59		#' select = "E",
60		#' keys = c("A", "B"),
61		#' reshape = FALSE,
62		#' internal_id = "x"
63		#' ),
64		#' list(
65		#' dataname = "Y",
66		#' filters = NULL,
67		#' select = "G",
68		#' keys = c("A", "C"),
69		#' reshape = FALSE,
70		#' internal_id = "y"
71		#' )
72		#' )
73		#'
74		#' data_list <- list(X = reactive(X), Y = reactive(Y))
75		#'
76		#' merged_datasets <- isolate(
77		#' merge_datasets(
78		#' selector_list = selector_list,
79		#' datasets = data_list,
80		#' join_keys = join_keys
81		#' )
82		#' )
83		#'
84		#' paste(merged_datasets$expr)
85		#' @export
86		#'
87		merge_datasets <- function(selector_list, datasets, join_keys, merge_function = "dplyr::full_join", anl_name = "ANL") {
88	6x	logger::log_trace(
89	6x	paste(
90	6x	"merge_datasets called with:",
91	6x	"{ paste(names(datasets), collapse = ', ') } datasets;",
92	6x	"{ paste(names(selector_list), collapse = ', ') } selectors;",
93	6x	"{ merge_function } merge function."
94		)
95		)
96
97	6x	checkmate::assert_list(selector_list, min.len = 1)
98	6x	checkmate::assert_string(anl_name)
99	6x	checkmate::assert_list(datasets, names = "named")
100	6x	checkmate::assert_class(join_keys, "join_keys")
101	6x	stopifnot(attr(regexec("[A-Za-z0-9\\_]*", anl_name)[[1]], "match.length") == nchar(anl_name))
102	6x	lapply(selector_list, check_selector)
103	6x	merge_selectors_out <- merge_selectors(selector_list)
104	6x	merged_selector_list <- merge_selectors_out[[1]]
105	6x	merged_selector_map_id <- merge_selectors_out[[2]]
106	6x	check_data_merge_selectors(merged_selector_list)
107
108	6x	dplyr_call_data <- get_dplyr_call_data(merged_selector_list, join_keys)
109
110	6x	validate_keys_sufficient(join_keys, merged_selector_list)
111
112	6x	columns_source <- mapply(
113	6x	function(id_from, id_to) {
114	10x	id_data <- vapply(dplyr_call_data, `[[`, character(1), "internal_id")
115	10x	out_cols <- dplyr_call_data[[which(id_to == id_data)]][["out_cols_renamed"]]
116	10x	id_selector <- vapply(selector_list, `[[`, character(1), "internal_id")
117	10x	res <- out_cols[names(out_cols) %in% selector_list[[which(id_from == id_selector)]][["select"]]]
118	10x	attr(res, "dataname") <- selector_list[[which(id_from == id_selector)]]$dataname
119	10x	always_selected <- selector_list[[which(id_from == id_selector)]]$always_selected
120	10x	if (is.null(always_selected)) {
121	10x	attr(res, "always_selected") <- character(0)
122		} else {
123	!	attr(res, "always_selected") <- always_selected
124		}
125	10x	res
126		},
127	6x	id_from = names(merged_selector_map_id),
128	6x	id_to = merged_selector_map_id,
129	6x	SIMPLIFY = FALSE
130		)
131
132	6x	dplyr_calls <- lapply(seq_along(merged_selector_list), function(idx) {
133	10x	dplyr_call <- get_dplyr_call(
134	10x	selector_list = merged_selector_list,
135	10x	idx = idx,
136	10x	dplyr_call_data = dplyr_call_data,
137	10x	datasets = datasets
138		)
139	10x	anl_i_call <- call("<-", as.name(paste0(anl_name, "_", idx)), dplyr_call)
140	10x	anl_i_call
141		})
142
143	6x	anl_merge_calls <- get_merge_call(
144	6x	selector_list = merged_selector_list,
145	6x	dplyr_call_data = dplyr_call_data,
146	6x	merge_function = merge_function,
147	6x	anl_name = anl_name
148		)
149
150	6x	anl_relabel_call <- get_anl_relabel_call(
151	6x	columns_source = get_relabel_cols(columns_source, dplyr_call_data), # don't relabel reshaped cols
152	6x	datasets = datasets,
153	6x	anl_name = anl_name
154		)
155
156	6x	all_calls_expression <- c(dplyr_calls, anl_merge_calls, anl_relabel_call)
157
158		# keys in each merged_selector_list element should be identical
159		# so take first one
160	6x	keys <- merged_selector_list[[1]]$keys
161
162	6x	filter_info <- lapply(merged_selector_list, "[[", "filters")
163
164	6x	res <- list(
165	6x	expr = all_calls_expression,
166	6x	columns_source = columns_source,
167	6x	keys = keys,
168	6x	filter_info = filter_info
169		)
170	6x	logger::log_trace("merge_datasets merge code executed resulting in { anl_name } dataset.")
171	6x	res
172		}
173
174		#' Merge selectors when `dataname`, `reshape`, `filters` and `keys` entries are identical
175		#'
176		#' @inheritParams merge_datasets
177		#'
178		#' @return List of merged selectors or original parameter if the conditions to merge are
179		#' not applicable.
180		#'
181		#' @keywords internal
182		#'
183		merge_selectors <- function(selector_list) {
184	66x	logger::log_trace("merge_selectors called with: { paste(names(selector_list), collapse = ', ') } selectors.")
185	66x	checkmate::assert_list(selector_list, min.len = 1)
186	66x	lapply(selector_list, check_selector)
187
188		# merge map - idx to value
189		# e.g. 1 2 1 means that 3rd selector is merged to 1st selector
190	66x	res_map_idx <- seq_along(selector_list)
191	66x	for (idx1 in res_map_idx) {
192	141x	selector_idx1 <- selector_list[[idx1]]
193	141x	for (idx2 in utils::tail(seq_along(res_map_idx), -idx1)) {
194	113x	if (res_map_idx[idx2] != idx2) {
195	16x	next
196		}
197	97x	selector_idx2 <- selector_list[[idx2]]
198		if (
199	97x	identical(selector_idx1$dataname, selector_idx2$dataname) &&
200	97x	identical(selector_idx1$reshape, selector_idx2$reshape) &&
201	97x	identical(selector_idx1$filters, selector_idx2$filters) &&
202	97x	identical(selector_idx1$keys, selector_idx2$keys)
203		) {
204	19x	res_map_idx[idx2] <- idx1
205		}
206		}
207		}
208
209	66x	res_map_id <- stats::setNames(
210	66x	vapply(selector_list[res_map_idx], `[[`, character(1), "internal_id"),
211	66x	vapply(selector_list, `[[`, character(1), "internal_id")
212		)
213
214
215	66x	res_list <- selector_list
216	66x	for (idx in seq_along(res_map_idx)) {
217	141x	idx_val <- res_map_idx[[idx]]
218	141x	if (idx != idx_val) {
219		# merge selector to the "first" identical subset
220	19x	res_list[[idx_val]]$select <- union(res_list[[idx_val]]$select, selector_list[[idx]]$select)
221		}
222		}
223	66x	for (idx in rev(seq_along(res_map_idx))) {
224	141x	idx_val <- res_map_idx[[idx]]
225	141x	if (idx != idx_val) {
226	19x	res_list[[idx]] <- NULL
227		}
228		}
229
230	66x	list(res_list, res_map_id)
231		}
232
233
234		#' Validate data_extracts in merge_datasets
235		#'
236		#' Validate selected inputs from data_extract before passing to data_merge to avoid
237		#' `dplyr` errors or unexpected results.
238		#'
239		#' @inheritParams merge_datasets
240		#'
241		#' @return `NULL` if check is successful and `shiny` validate error otherwise.
242		#'
243		#' @keywords internal
244		#'
245		check_data_merge_selectors <- function(selector_list) {
246		# check if reshape n empt select or just primary keys
247	6x	lapply(selector_list, function(x) {
248	10x	if (x$reshape & length(setdiff(x$select, x$keys)) == 0) {
249	!	validate(need(
250	!	FALSE,
251	!	"Error in data_extract_spec setup:\
252	!	\tPlease select non-key column to be reshaped from long to wide format."
253		))
254		}
255		})
256	6x	NULL
257		}
258
259		#' Validates whether the provided keys are sufficient to merge the datasets slices
260		#'
261		#' @note
262		#' The keys are not sufficient if the datasets slices described in
263		#' `merged_selector_list` come from datasets, which don't have the
264		#' appropriate join keys in `join_keys`.
265		#'
266		#' @param join_keys (`join_keys`) the provided join keys.
267		#' @param merged_selector_list (`list`) the specification of datasets' slices to merge.
268		#'
269		#' @return `TRUE` if the provided keys meet the requirement and `shiny`
270		#' validate error otherwise.
271		#'
272		#' @keywords internal
273		#'
274		validate_keys_sufficient <- function(join_keys, merged_selector_list) {
275	8x	validate(
276	8x	need(
277	8x	are_needed_keys_provided(join_keys, merged_selector_list),
278	8x	message = paste(
279	8x	"Cannot merge at least two dataset extracts.",
280	8x	"Make sure all datasets used for merging have appropriate keys."
281		)
282		)
283		)
284
285	7x	TRUE
286		}
287
288		#' Checks whether the provided slices have the corresponding join keys
289		#'
290		#' @note
291		#' `merged_selector_list` contains a list of descriptions of data frame slices;
292		#' each coming from a single dataset. This function checks whether all pairs
293		#' of the datasets have the join keys needed to merge the slices.
294		#'
295		#' @inheritParams validate_keys_sufficient
296		#'
297		#' @return `TRUE` if all pairs of the slices have the corresponding keys and
298		#' `FALSE` otherwise.
299		#'
300		#' @keywords internal
301		#'
302		are_needed_keys_provided <- function(join_keys, merged_selector_list) {
303		# because one slice doesn't have to be merged with anything
304	13x	if (length(merged_selector_list) <= 1) {
305	6x	return(TRUE)
306		}
307
308	7x	do_join_keys_exist <- function(dataset_name1, dataset_name2, join_keys) {
309	11x	length(join_keys[dataset_name1, dataset_name2] > 0)
310		}
311
312	7x	datasets_names <- vapply(merged_selector_list, function(slice) slice[["dataname"]], FUN.VALUE = character(1))
313	7x	datasets_names_pairs <- utils::combn(datasets_names, m = 2)
314	7x	datasets_names_pairs <- datasets_names_pairs[, !duplicated(t(datasets_names_pairs)), drop = FALSE]
315
316	7x	datasets_pairs_keys_present <- apply(
317	7x	datasets_names_pairs,
318	7x	MARGIN = 2,
319	7x	FUN = function(names_pair) do_join_keys_exist(names_pair[1], names_pair[2], join_keys)
320		)
321
322	6x	all(datasets_pairs_keys_present)
323		}

1		#' Get merge call from a list of selectors
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' Creates list of calls depending on selector(s) and type of the merge.
7		#' The merge order is the same as in selectors passed to the function.
8		#'
9		#' @inheritParams merge_datasets
10		#' @param join_keys (`join_keys`) nested list of keys used for joining.
11		#' @param dplyr_call_data (`list`) simplified selectors with aggregated set of filters.
12		#'
13		#' @return List with merge `call` elements.
14		#'
15		#' @export
16		#'
17		get_merge_call <- function(selector_list,
18		join_keys = teal.data::join_keys(),
19		dplyr_call_data = get_dplyr_call_data(selector_list, join_keys = join_keys),
20		merge_function = "dplyr::full_join",
21		anl_name = "ANL") {
22	68x	if (!missing(selector_list)) {
23	68x	checkmate::assert_list(selector_list, min.len = 1)
24	68x	lapply(selector_list, check_selector)
25	68x	logger::log_trace(
26	68x	paste(
27	68x	"get_merge_call called with: { paste(names(selector_list), collapse = ', ') } selectors;",
28	68x	"{ merge_function } merge function."
29		)
30		)
31		} else {
32	!	logger::log_trace(
33	!	paste(
34	!	"get_merge_call called with:",
35	!	"{ paste(sapply(dplyr_call_data, `[[`, 'internal_id'), collapse = ', ') } selectors;",
36	!	"{ merge_function } merge function."
37		)
38		)
39		}
40
41	68x	checkmate::assert_string(anl_name)
42	68x	stopifnot(attr(regexec("[A-Za-z0-9\\_]*", anl_name)[[1]], "match.length") == nchar(anl_name))
43	68x	check_merge_function(merge_function)
44
45
46	66x	n_selectors <- if (!missing(selector_list)) {
47	66x	length(selector_list)
48		} else {
49	!	length(dplyr_call_data)
50		}
51
52	66x	anl_merge_calls <- list(
53	66x	call("<-", as.name(anl_name), as.name(paste0(anl_name, "_", 1)))
54		)
55
56	66x	for (idx in seq_len(n_selectors)[-1]) {
57	59x	anl_merge_call_i <- call(
58		"<-",
59	59x	as.name(anl_name),
60		{
61	59x	merge_key_i <- get_merge_key_i(idx = idx, dplyr_call_data = dplyr_call_data)
62	59x	is_merge_key_pair <- vapply(merge_key_i, function(x) length(names(x)) == 1, logical(1))
63
64	59x	join_call <- as.call(
65	59x	c(
66	59x	rlang::parse_expr(merge_function),
67	59x	list(
68	59x	as.name(anl_name),
69	59x	as.name(paste0(anl_name, "_", idx))
70		),
71	59x	if (!rlang::is_empty(merge_key_i)) {
72	59x	list(
73	59x	by = parse_merge_key_i(merge_key = merge_key_i)
74		)
75		}
76		)
77		)
78
79		# mutate call to get second key if any pair key
80		# e.g. full_join(dt1, dt2, by = c("key1" = "key2")) %>% mutate(key2 = key1)
81		# it's because dplyr joins preserve only key from LHS data
82	59x	mutate_call <- if (any(is_merge_key_pair)) {
83	1x	merge_key_pairs <- merge_key_i[is_merge_key_pair]
84		# drop duplicates ignoring names
85	1x	idx <- vapply(unique(unlist(merge_key_pairs)), function(x1) {
86	2x	which.min(vapply(merge_key_pairs, function(x2) x2 == x1, logical(1)))
87	1x	}, integer(1))
88
89	1x	merge_key_pairs <- merge_key_pairs[idx]
90	1x	as.call(
91	1x	append(
92	1x	quote(dplyr::mutate),
93	1x	stats::setNames(
94	1x	lapply(merge_key_pairs, function(x) as.name(names(x))),
95	1x	merge_key_pairs
96		)
97		)
98		)
99		} else {
100	58x	NULL
101		}
102
103	59x	Reduce(
104	59x	function(x, y) call("%>%", x, y),
105	59x	c(join_call, mutate_call)
106		)
107		}
108		)
109
110	59x	anl_merge_calls <- append(
111	59x	anl_merge_calls,
112	59x	anl_merge_call_i
113		)
114		}
115
116	66x	anl_merge_calls
117		}
118
119		#' Gets merge key pair list from keys list
120		#'
121		#' @inheritParams get_merge_call
122		#'
123		#' @return List of merge key pairs between all datasets.
124		#'
125		#' @keywords internal
126		#'
127		get_merge_key_grid <- function(selector_list, join_keys = teal.data::join_keys()) {
128	163x	logger::log_trace(
129	163x	"get_merge_key_grid called with: { paste(names(selector_list), collapse = ', ') } selectors."
130		)
131
132	163x	lapply(
133	163x	selector_list,
134	163x	function(selector_from) {
135	361x	lapply(
136	361x	selector_list,
137	361x	function(selector_to) {
138	911x	get_merge_key_pair(
139	911x	selector_from,
140	911x	selector_to,
141	911x	join_keys[selector_from$dataname, selector_to$dataname]
142		)
143		}
144		)
145		}
146		)
147		}
148
149		#' Gets keys vector from keys list
150		#'
151		#' @details
152		#' This function covers up to now 4 cases:
153		#'
154		#' * Dataset without parent: Primary keys are returned;
155		#' * Dataset source = dataset target:
156		#' The primary keys subtracted of all key columns that get purely filtered.
157		#' This means just one value would be left after filtering inside this column
158		#' Then it can be taken out;
159		#' * Target `dataname` is parent foreign keys;
160		#' * Any other case foreign keys;
161		#'
162		#' @param selector_from (`list`) of `data_extract_srv` objects.
163		#' @param selector_to (`list`) of `data_extract_srv` objects.
164		#' @param key_from (`character`) keys used in the first selector while joining.
165		#'
166		#' @return `character` vector of selector keys.
167		#'
168		#' @keywords internal
169		#'
170		get_merge_key_pair <- function(selector_from, selector_to, key_from) {
171	927x	logger::log_trace(
172	927x	paste(
173	927x	"get_merge_key_pair called with:",
174	927x	"{ paste(selector_from$internal_id, selector_to$internal_id, sep = ', ') } selectors;",
175	927x	"{ paste(key_from, collapse = ', ') } keys."
176		)
177		)
178	927x	check_selector(selector_from)
179	927x	check_selector(selector_to)
180	927x	checkmate::test_character(key_from, min.len = 0, any.missing = FALSE)
181
182	927x	res <- if (identical(selector_from$dataname, selector_to$dataname)) {
183		# key is dropped if reshape or if filtered out (only one level selected)
184	627x	keys_dropped <- if (isTRUE(selector_from$reshape)) {
185	167x	get_reshape_unite_col(selector_from)
186		} else {
187	460x	get_dropped_filters(selector_from)
188		}
189	627x	res <- setdiff(
190	627x	key_from,
191	627x	keys_dropped
192		)
193	430x	if (!rlang::is_empty(res)) res <- rlang::set_names(res)
194	627x	res
195		} else {
196	300x	key_from
197		}
198	927x	logger::log_trace("get_merge_key_pair returns { paste(res, collapse = ', ') } merge keys.")
199	927x	res
200		}
201
202		#' Gets keys needed for join call of two selectors
203		#'
204		#' @inheritParams get_merge_call
205		#' @param idx (optional `integer`) current selector index in all selectors list.
206		#'
207		#' @return `character` list of keys.
208		#'
209		#' @keywords internal
210		#'
211		get_merge_key_i <- function(selector_list, idx, dplyr_call_data = get_dplyr_call_data(selector_list)) {
212	59x	checkmate::assert_integer(idx, len = 1, any.missing = FALSE, lower = 2L)
213
214	59x	if (!missing(selector_list)) {
215	!	checkmate::assert_list(selector_list, min.len = 1)
216	!	lapply(selector_list, check_selector)
217
218	!	logger::log_trace(
219	!	paste(
220	!	"get_merge_key_i called with:",
221	!	"{ paste(names(selector_list), collapse = ', ') } selectors;",
222	!	"idx = { idx }."
223		)
224		)
225		} else {
226	59x	logger::log_trace(
227	59x	paste(
228	59x	"get_merge_key_i called with",
229	59x	"{ paste(sapply(dplyr_call_data, `[[`, 'internal_id'), collapse = ', ') } selectors;",
230	59x	"idx = { idx }."
231		)
232		)
233		}
234
235	59x	merge_keys_list <- lapply(dplyr_call_data, `[[`, "merge_keys_list")
236
237		# keys x - get from all selectors up to the current one
238	59x	keys_x <- lapply(merge_keys_list[seq_len(idx - 1)], `[[`, idx)
239
240		# keys y - get from the current selector
241	59x	keys_y <- merge_keys_list[[idx]][seq_len(idx - 1)]
242
243	59x	keys_map <- lapply(
244	59x	seq_len(idx - 1),
245	59x	function(idx2) {
246	76x	keys_x_idx2 <- keys_x[[idx2]]
247	76x	keys_y_idx2 <- keys_y[[idx2]]
248	76x	min_length <- min(length(keys_x_idx2), length(keys_y_idx2))
249
250		# In case the keys might be wrongly sorted, sort them
251	76x	if (!identical(keys_x_idx2[seq_len(min_length)], keys_y_idx2[seq_len(min_length)])) {
252	2x	keys_x_idx2 <- c(
253	2x	intersect(keys_x_idx2, keys_y_idx2),
254	2x	setdiff(keys_x_idx2, keys_y_idx2)
255		)
256
257	2x	keys_y_idx2 <- c(
258	2x	intersect(keys_y_idx2, keys_x_idx2),
259	2x	setdiff(keys_y_idx2, keys_x_idx2)
260		)
261		}
262		# cut keys case of different length
263	76x	keys_x_idx2 <- keys_x_idx2[seq_len(min_length)]
264	76x	keys_y_idx2 <- keys_y_idx2[seq_len(min_length)]
265
266	76x	mapply(
267	76x	function(x, y) {
268	161x	if (identical(x, y)) {
269	159x	x
270		} else {
271	2x	stats::setNames(nm = y, x)
272		}
273		},
274	76x	keys_x_idx2,
275	76x	keys_y_idx2,
276	76x	SIMPLIFY = FALSE,
277	76x	USE.NAMES = FALSE
278		)
279		}
280		)
281
282	59x	keys_map <- if (length(keys_map) > 1) {
283	16x	Reduce(append, keys_map)
284		} else {
285	43x	keys_map[[1]]
286		}
287
288	59x	keys_map <- unique(keys_map)
289	59x	logger::log_trace("get_merge_key_i returns { paste(keys_map, collapse = ' ') } unique keys.")
290	59x	keys_map
291		}
292
293		#' Parses merge keys
294		#'
295		#' @inheritParams get_merge_call
296		#' @param merge_key keys obtained from `get_merge_key_i`.
297		#' @param idx optional (`integer`) current selector index in all selectors list.
298		#'
299		#' @return `call` with merge keys.
300		#'
301		#' @keywords internal
302		#'
303		parse_merge_key_i <- function(selector_list,
304		idx,
305		dplyr_call_data = get_dplyr_call_data(selector_list),
306		merge_key = get_merge_key_i(selector_list, idx, dplyr_call_data)) {
307	59x	logger::log_trace("parse_merge_key_i called with { paste(merge_key, collapse = ' ') } keys.")
308	59x	as.call(
309	59x	append(
310	59x	quote(c),
311	59x	unlist(merge_key)
312		)
313		)
314		}
315
316		#' Names of filtered-out filters dropped from selection
317		#'
318		#' @details
319		#' Names of filtered-out filters dropped from automatic selection
320		#' (key vars are automatically included in select).
321		#' Dropped filter is filter which became not unique for all observations.
322		#' This means that if variable is filtered to just one level,
323		#' it's not a key anymore.
324		#'
325		#' Other variables used in filter should also be dropped from automatic
326		#' selection, unless they have been selected.
327		#'
328		#' @inheritParams get_pivot_longer_col
329		#'
330		#' @return Vector of `character` names of the filters which should be dropped from select call.
331		#'
332		#' @keywords internal
333		#'
334		get_dropped_filters <- function(selector) {
335	460x	logger::log_trace("get_dropped_filters called with { selector$internal_id } selector.")
336	460x	unlist(
337	460x	lapply(selector$filters, function(x) {
338	522x	if (isFALSE(x$drop_keys)) {
339	19x	NULL
340	503x	} else if (length(x$columns) > 1) {
341		# concatenated filters
342	61x	single_selection <- sapply(seq_along(x$columns), function(i) length(unique(sapply(x$selected, `[[`, i))) == 1)
343	61x	x$columns[single_selection]
344		} else {
345		# one filter in one input
346	294x	if (isFALSE(x$multiple) \|\| length(x$selected) == 1) x$columns
347		}
348		})
349		)
350		}
351
352
353		#' Gets the relabel call
354		#'
355		#' `r lifecycle::badge("stable")`
356		#'
357		#' @inheritParams merge_datasets
358		#' @param columns_source (named `list`)
359		#' where names are column names, values are labels + additional attribute `dataname`
360		#'
361		#' @return (`call`) to relabel `dataset` and assign to `anl_name`.
362		#'
363		#' @export
364		get_anl_relabel_call <- function(columns_source, datasets, anl_name = "ANL") {
365	6x	logger::log_trace(
366	6x	paste(
367	6x	"get_anl_relabel_call called with:",
368	6x	"{ paste(names(columns_source), collapse = ', ') } columns_source;",
369	6x	"{ anl_name } merged dataset."
370		)
371		)
372	6x	checkmate::assert_string(anl_name)
373	6x	stopifnot(attr(regexec("[A-Za-z0-9\\_]*", anl_name)[[1]], "match.length") == nchar(anl_name))
374	6x	labels_vector <- Reduce(
375	6x	function(x, y) append(x, y),
376	6x	lapply(
377	6x	columns_source,
378	6x	function(selector) {
379	10x	column_names <- names(selector)
380	10x	if (rlang::is_empty(column_names)) {
381	2x	return(NULL)
382		}
383
384	8x	data_used <- datasets[[attr(selector, "dataname")]]
385	8x	labels <- teal.data::col_labels(data_used(), fill = FALSE)
386	8x	column_labels <- labels[intersect(colnames(data_used()), column_names)]
387
388		# NULL for no labels at all, character(0) for no labels for a given columns
389	8x	return(
390	8x	if (rlang::is_empty(column_labels)) {
391	!	column_labels
392		} else {
393	8x	stats::setNames(
394	8x	column_labels,
395	8x	selector[names(column_labels)]
396		)
397		}
398		)
399		}
400		)
401		)
402
403	6x	if (length(labels_vector) == 0 \|\| all(is.na(labels_vector))) {
404	6x	return(NULL)
405		}
406
407	!	relabel_call <- call(
408		"%>%",
409	!	as.name(anl_name),
410	!	get_relabel_call(labels_vector)
411		)
412
413	!	relabel_and_assign_call <- call(
414		"<-",
415	!	as.name(anl_name),
416	!	relabel_call
417		)
418
419	!	relabel_and_assign_call
420		}
421
422		#' Create relabel call from named character
423		#'
424		#' @description
425		#' `r lifecycle::badge("stable")`
426		#'
427		#' Function creates relabel call from named character.
428		#'
429		#' @param labels (named `character`)
430		#' where name is name is function argument name and value is a function argument value.
431		#'
432		#' @return `call` object with relabel step.
433		#'
434		#' @examples
435		#' get_relabel_call(
436		#' labels = c(
437		#' x = as.name("ANL"),
438		#' AGE = "Age",
439		#' AVAL = "Continuous variable"
440		#' )
441		#' )
442		#'
443		#' get_relabel_call(
444		#' labels = c(
445		#' AGE = "Age",
446		#' AVAL = "Continuous variable"
447		#' )
448		#' )
449		#' @export
450		get_relabel_call <- function(labels) {
451	3x	logger::log_trace("get_relabel_call called with: { paste(labels, collapse = ' ' ) } labels.")
452	3x	if (length(stats::na.omit(labels)) == 0 \|\| is.null(names(labels))) {
453	2x	return(NULL)
454		}
455	1x	labels <- labels[!duplicated(names(labels))]
456	1x	labels <- labels[!is.na(labels)]
457
458	1x	as.call(
459	1x	append(
460	1x	quote(teal.data::col_relabel),
461	1x	labels
462		)
463		)
464		}
465
466		#' Get columns to relabel
467		#'
468		#' Get columns to relabel excluding these which has been reshaped (pivot_wider).
469		#'
470		#' @param columns_source (`list`)
471		#' @param dplyr_call_data (`list`)
472		#'
473		#' @return `columns_source` list without columns that have been reshaped.
474		#'
475		#' @keywords internal
476		#'
477		get_relabel_cols <- function(columns_source, dplyr_call_data) {
478	6x	logger::log_trace(
479	6x	"get_relabel_cols called with: { paste(names(columns_source), collapse = ', ') } columns_source."
480		)
481	6x	pivot_longer_cols <- unlist(unname(lapply(dplyr_call_data, function(x) x[["pivot_longer_cols_renamed"]])))
482	6x	lapply(
483	6x	columns_source,
484	6x	function(column_source) {
485	10x	dataname <- attr(column_source, "dataname")
486	10x	column_source <- column_source[!names(column_source) %in% pivot_longer_cols]
487	10x	if (length(column_source) == 0) {
488	2x	return(NULL)
489		}
490	8x	attr(column_source, "dataname") <- dataname
491	8x	column_source
492		}
493		)
494		}

1		#' Set "`<choice>:<label>`" type of names
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' This is often useful for [choices_selected()] as it marks up the drop-down boxes
7		#' for [shiny::selectInput()].
8		#'
9		#' @details
10		#' If either `choices` or `labels` are factors, they are coerced to character.
11		#' Duplicated elements from `choices` get removed.
12		#'
13		#' @param choices (`character` or `factor` or `numeric` or `logical`) vector.
14		#' @param labels (`character`) vector containing labels to be applied to `choices`.
15		#' If `NA` then "Label Missing" will be used.
16		#' @param subset (`character` or `factor` or `numeric` or `logical`) vector that
17		#' is a subset of `choices`.
18		#' This is useful if only a few variables need to be named.
19		#' If this argument is used, the returned vector will match its order.
20		#' @param types (`character`) vector containing the types of the columns to be used for applying the appropriate
21		#' icons to the [choices_selected] drop down box (e.g. "numeric").
22		#'
23		#' @return Named `character` vector.
24		#'
25		#' @examples
26		#' library(shiny)
27		#' library(teal.data)
28		#'
29		#' ADSL <- teal.transform::rADSL
30		#' ADTTE <- teal.transform::rADTTE
31		#'
32		#' choices1 <- choices_labeled(names(ADSL), col_labels(ADSL, fill = FALSE))
33		#' choices2 <- choices_labeled(ADTTE$PARAMCD, ADTTE$PARAM)
34		#'
35		#' # if only a subset of variables are needed, use subset argument
36		#' choices3 <- choices_labeled(
37		#' names(ADSL),
38		#' col_labels(ADSL, fill = FALSE),
39		#' subset = c("ARMCD", "ARM")
40		#' )
41		#'
42		#' ui <- fluidPage(
43		#' selectInput("c1",
44		#' label = "Choices from ADSL",
45		#' choices = choices1,
46		#' selected = choices1[1]
47		#' ),
48		#' selectInput("c2",
49		#' label = "Choices from ADTTE",
50		#' choices = choices2,
51		#' selected = choices2[1]
52		#' ),
53		#' selectInput("c3",
54		#' label = "Arm choices from ADSL",
55		#' choices = choices3,
56		#' selected = choices3[1]
57		#' )
58		#' )
59		#' server <- function(input, output) {}
60		#'
61		#' if (interactive()) {
62		#' shinyApp(ui, server)
63		#' }
64		#' @export
65		#'
66		choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
67	244x	if (is.factor(choices)) {
68	!	choices <- as.character(choices)
69		}
70
71	244x	checkmate::assert_atomic(choices, min.len = 1, any.missing = FALSE)
72
73	244x	if (is.factor(labels)) {
74	!	labels <- as.character(labels)
75		}
76
77	244x	checkmate::assert_character(labels[!is.na(labels)], any.missing = FALSE)
78	244x	if (length(choices) != length(labels)) {
79	!	stop("length of choices must be the same as labels")
80		}
81	244x	checkmate::assert_subset(subset, choices, empty.ok = TRUE)
82	244x	checkmate::assert_character(types, len = length(choices), null.ok = TRUE)
83
84	244x	if (!is.null(subset)) {
85	224x	if (!all(subset %in% choices)) {
86	!	stop("all of subset variables must be in choices")
87		}
88	224x	labels <- labels[choices %in% subset]
89	224x	types <- types[choices %in% subset]
90	224x	choices <- choices[choices %in% subset]
91		}
92
93	244x	is_dupl <- duplicated(choices)
94	244x	choices <- choices[!is_dupl]
95	244x	labels <- labels[!is_dupl]
96	244x	types <- types[!is_dupl]
97	244x	labels[is.na(labels)] <- "Label Missing"
98	244x	raw_labels <- labels
99	244x	combined_labels <- if (length(choices) > 0) {
100	244x	paste0(choices, ": ", labels)
101		} else {
102	!	character(0)
103		}
104
105	244x	if (!is.null(subset)) {
106	224x	ord <- match(subset, choices)
107	224x	choices <- choices[ord]
108	224x	raw_labels <- raw_labels[ord]
109	224x	combined_labels <- combined_labels[ord]
110	224x	types <- types[ord]
111		}
112
113	244x	structure(
114	244x	choices,
115	244x	names = combined_labels,
116	244x	raw_labels = raw_labels,
117	244x	combined_labels = combined_labels,
118	244x	class = c("choices_labeled", "character"),
119	244x	types = types
120		)
121		}
122
123		#' Variable label extraction and custom selection from data
124		#'
125		#' @description
126		#' `r lifecycle::badge("stable")`
127		#'
128		#' Wrapper on [choices_labeled] to label variables basing on existing labels in data.
129		#'
130		#' @rdname variable_choices
131		#'
132		#' @param data (`data.frame` or `character`)
133		#' If `data.frame`, then data to extract labels from.
134		#' If `character`, then name of the dataset to extract data from once available.
135		#' @param subset (`character` or `function`)
136		#' If `character`, then a vector of column names.
137		#' If `function`, then this function is used to determine the possible columns (e.g. all factor columns).
138		#' In this case, the function must take only single argument "data" and return a character vector.
139		#'
140		#' See examples for more details.
141		#' @param key (`character`) vector with names of the variables, which are part of the primary key
142		#' of the `data` argument.
143		#'
144		#' This is an optional argument, which allows to identify variables associated
145		#' with the primary key and display the appropriate icon for them in the
146		#' [teal.widgets::optionalSelectInput()] widget.
147		#' @param fill (`logical(1)`) if `TRUE`, the function will return variable names
148		#' for columns with non-existent labels; otherwise will return `NA` for them.
149		#'
150		#' @return Named `character` vector with additional attributes or `delayed_data` object.
151		#'
152		#' @examples
153		#' library(teal.data)
154		#'
155		#' ADRS <- teal.transform::rADRS
156		#' variable_choices(ADRS)
157		#' variable_choices(ADRS, subset = c("PARAM", "PARAMCD"))
158		#' variable_choices(ADRS, subset = c("", "PARAM", "PARAMCD"))
159		#' variable_choices(
160		#' ADRS,
161		#' subset = c("", "PARAM", "PARAMCD"),
162		#' key = default_cdisc_join_keys["ADRS", "ADRS"]
163		#' )
164		#'
165		#' # delayed version
166		#' variable_choices("ADRS", subset = c("USUBJID", "STUDYID"))
167		#'
168		#' # functional subset (with delayed data) - return only factor variables
169		#' variable_choices("ADRS", subset = function(data) {
170		#' idx <- vapply(data, is.factor, logical(1))
171		#' names(data)[idx]
172		#' })
173		#' @export
174		#'
175		variable_choices <- function(data, subset = NULL, fill = FALSE, key = NULL) {
176	250x	checkmate::assert(
177	250x	checkmate::check_character(subset, null.ok = TRUE, any.missing = FALSE),
178	250x	checkmate::check_function(subset)
179		)
180	250x	checkmate::assert_flag(fill)
181	250x	checkmate::assert_character(key, null.ok = TRUE, any.missing = FALSE)
182
183	250x	UseMethod("variable_choices")
184		}
185
186		#' @rdname variable_choices
187		#' @export
188		variable_choices.character <- function(data, subset = NULL, fill = FALSE, key = NULL) {
189	84x	structure(list(data = data, subset = subset, key = key),
190	84x	class = c("delayed_variable_choices", "delayed_data", "choices_labeled")
191		)
192		}
193
194		#' @rdname variable_choices
195		#' @export
196		variable_choices.data.frame <- function(data, subset = NULL, fill = TRUE, key = NULL) {
197	166x	checkmate::assert(
198	166x	checkmate::check_character(subset, null.ok = TRUE),
199	166x	checkmate::check_function(subset, null.ok = TRUE)
200		)
201
202	166x	if (is.function(subset)) {
203	4x	subset <- resolve_delayed_expr(subset, ds = data, is_value_choices = FALSE)
204		}
205
206	166x	checkmate::assert_subset(subset, c("", names(data)), empty.ok = TRUE)
207
208	166x	if (length(subset) == 0) {
209	21x	subset <- names(data)
210		}
211
212	166x	key <- intersect(subset, key)
213
214	166x	var_types <- vapply(data, function(x) class(x)[[1]], character(1))
215
216	166x	if (length(key) != 0) {
217	52x	var_types[key] <- "primary_key"
218		}
219
220	166x	if (any(duplicated(subset))) {
221	!	warning(
222	!	"removed duplicated entries in subset:",
223	!	paste(unique(subset[duplicated(subset)]), collapse = ", ")
224		)
225	!	subset <- unique(subset)
226		}
227
228	166x	if ("" %in% subset) {
229	!	choices_labeled(
230	!	choices = c("", names(data)),
231	!	labels = c("", unname(teal.data::col_labels(data, fill = fill))),
232	!	subset = subset,
233	!	types = c("", var_types)
234		)
235		} else {
236	166x	choices_labeled(
237	166x	choices = names(data),
238	166x	labels = unname(teal.data::col_labels(data, fill = fill)),
239	166x	subset = subset,
240	166x	types = var_types
241		)
242		}
243		}
244
245		#' Value labeling and filtering based on variable relationship
246		#'
247		#' @description
248		#' `r lifecycle::badge("stable")`
249		#'
250		#' Wrapper on [choices_labeled] to label variable values basing on other variable values.
251		#'
252		#' @rdname value_choices
253		#'
254		#' @param data (`data.frame`, `character`)
255		#' If `data.frame`, then data to extract labels from.
256		#' If `character`, then name of the dataset to extract data from once available.
257		#' @param var_choices (`character` or `NULL`) vector with choices column names.
258		#' @param var_label (`character`) vector with labels column names.
259		#' @param subset (`character` or `function`)
260		#' If `character`, vector with values to subset.
261		#' If `function`, then this function is used to determine the possible columns (e.g. all factor columns).
262		#' In this case, the function must take only single argument "data" and return a character vector.
263		#'
264		#' See examples for more details.
265		#' @param sep (`character`) separator used in case of multiple column names.
266		#'
267		#' @return named character vector or `delayed_data` object.
268		#'
269		#' @examples
270		#' ADRS <- teal.transform::rADRS
271		#' value_choices(ADRS, "PARAMCD", "PARAM", subset = c("BESRSPI", "INVET"))
272		#' value_choices(ADRS, c("PARAMCD", "ARMCD"), c("PARAM", "ARM"))
273		#' value_choices(ADRS, c("PARAMCD", "ARMCD"), c("PARAM", "ARM"),
274		#' subset = c("BESRSPI - ARM A", "INVET - ARM A", "OVRINV - ARM A")
275		#' )
276		#' value_choices(ADRS, c("PARAMCD", "ARMCD"), c("PARAM", "ARM"), sep = " --- ")
277		#'
278		#' # delayed version
279		#' value_choices("ADRS", c("PARAMCD", "ARMCD"), c("PARAM", "ARM"))
280		#'
281		#' # functional subset
282		#' value_choices(ADRS, "PARAMCD", "PARAM", subset = function(data) {
283		#' levels(data$PARAMCD)[1:2]
284		#' })
285		#' @export
286		#'
287		value_choices <- function(data,
288		var_choices,
289		var_label = NULL,
290		subset = NULL,
291		sep = " - ") {
292	123x	checkmate::assert_character(var_choices, any.missing = FALSE)
293	123x	checkmate::assert_character(var_label, len = length(var_choices), null.ok = TRUE, any.missing = FALSE)
294	123x	checkmate::assert(
295	123x	checkmate::check_vector(subset, null.ok = TRUE),
296	123x	checkmate::check_function(subset)
297		)
298	123x	checkmate::assert_string(sep)
299	123x	UseMethod("value_choices")
300		}
301
302		#' @rdname value_choices
303		#' @export
304		value_choices.character <- function(data,
305		var_choices,
306		var_label = NULL,
307		subset = NULL,
308		sep = " - ") {
309	43x	structure(
310	43x	list(
311	43x	data = data,
312	43x	var_choices = var_choices,
313	43x	var_label = var_label,
314	43x	subset = subset,
315	43x	sep = sep
316		),
317	43x	class = c("delayed_value_choices", "delayed_data", "choices_labeled")
318		)
319		}
320
321		#' @rdname value_choices
322		#' @export
323		value_choices.data.frame <- function(data,
324		var_choices,
325		var_label = NULL,
326		subset = NULL,
327		sep = " - ") {
328	80x	checkmate::assert_subset(var_choices, names(data))
329	79x	checkmate::assert_subset(var_label, names(data), empty.ok = TRUE)
330
331	78x	df_choices <- data[var_choices]
332	78x	df_label <- data[var_label]
333
334	78x	for (i in seq_along(var_choices)) {
335	85x	if ("NA" %in% c(df_choices[[i]], levels(df_choices[[i]])) && any(is.na(df_choices[[i]]))) {
336	6x	warning(paste0(
337	6x	"Missing values and the string value of 'NA' both exist in the column of ", var_choices[i],
338	6x	" either as value(s) or level(s). ",
339	6x	"This will cause the missing values to be grouped with the actual string 'NA' values in the UI widget."
340		))
341		}
342		}
343
344	78x	choices <- if (
345	78x	length(var_choices) > 1 \|\|
346	78x	is.character(df_choices[[1]]) \|\|
347	78x	is.factor(df_choices[[1]]) \|\|
348	78x	inherits(df_choices[[1]], c("Date", "POSIXct", "POSIXlt", "POSIXt"))
349		) {
350	78x	df_choices <- dplyr::mutate_if(
351	78x	df_choices,
352	78x	.predicate = function(col) inherits(col, c("POSIXct", "POSIXlt", "POSIXt")),
353	78x	.funs = function(col) {
354	!	if (is.null(attr(col, "tzone")) \|\| all(attr(col, "tzone") == "")) {
355	!	format(trunc(col), "%Y-%m-%d %H:%M:%S")
356		} else {
357	!	format(trunc(col), "%Y-%m-%d %H:%M:%S %Z")
358		}
359		}
360		)
361	78x	apply(df_choices, 1, paste, collapse = sep)
362		} else {
363	!	df_choices[[var_choices]]
364		}
365	78x	labels <- apply(df_label, 1, paste, collapse = sep)
366	78x	df <- unique(data.frame(choices, labels, stringsAsFactors = FALSE)) # unique combo of choices x labels
367
368	78x	if (is.function(subset)) {
369	5x	subset <- resolve_delayed_expr(subset, ds = data, is_value_choices = TRUE)
370		}
371	78x	res <- choices_labeled(
372	78x	choices = df$choices,
373	78x	labels = df$labels,
374	78x	subset = subset
375		)
376	78x	attr(res, "sep") <- sep
377	78x	attr(res, "var_choices") <- var_choices
378	78x	attr(res, "var_label") <- var_label
379	78x	res
380		}
381
382		#' @describeIn choices_labeled Print choices_labeled object
383		#'
384		#' @param x an object used to select a method.
385		#' @param ... further arguments passed to or from other methods.
386		#'
387		#' @export
388		#'
389		print.choices_labeled <- function(x, ...) {
390	!	cat(
391	!	sprintf("number of choices: %s \n", length(x)),
392	!	names(x),
393		"",
394	!	sep = "\n"
395		)
396
397	!	invisible(x)
398		}

1		#' Resolve delayed inputs by evaluating the code within the provided datasets
2		#'
3		#' `r lifecycle::badge("stable")`
4		#'
5		#' @note This is an internal function that is used by [resolve_delayed()].
6		#' All the methods are used internally only.
7		#'
8		#' @param x (`delayed_data`) object to resolve.
9		#' @param datasets (named `list` of `data.frame`) to use in evaluation.
10		#' @param keys (named `list` of `character`) to be used as the keys for each dataset.
11		#' The names of this list must be exactly the same as for datasets.
12		#'
13		#' @return Resolved object.
14		#'
15		#' @keywords internal
16		#'
17		resolve <- function(x, datasets, keys = NULL) {
18	269x	checkmate::assert_list(datasets, types = "reactive", min.len = 1, names = "named")
19	266x	checkmate::assert_list(keys, "character", names = "named", null.ok = TRUE)
20	264x	checkmate::assert(
21	264x	.var.name = "keys",
22	264x	checkmate::check_names(names(keys), subset.of = names(datasets)),
23	264x	checkmate::check_null(keys)
24		)
25