teal.transform coverage - 82.38%

Files
Source

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()]
#'
#' @param choices (`character`) vector of possible choices or `delayed_data` object\cr
#'   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
#'  a `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`)\cr
#'  In case of `FALSE` the selected variables will be on top of the drop-down field.
#' @param fixed optional, (`logical`)\cr
#'  Whether to block user to select choices
#'
#' @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`.
#'
#' @return Object of class `choices_selected` and of type list which contains the specified
#'   `choices`, `selected`, `keep_order` and `fixed`.
#'
#' @export
#'
#' @examples
#'
#' library(shiny)
#'
#' # all_choices example - semantically the same objects
#' choices_selected(choices = letters, selected = all_choices())
#' choices_selected(choices = letters, selected = letters)
#'
#' choices_selected(
#'   choices = stats::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))
#'   return(names(data)[idx])
#' }))
#'
#' cs <- choices_selected(
#'   choices = c("A", "B", "C"),
#'   selected = "A"
#' )
#'
#' ui <- fluidPage(
#'   teal.widgets::optionalSelectInput(
#'     inputId = "id",
#'     choices = cs$choices,
#'     selected = cs$selected
#'   )
#' )
#' \dontrun{
#' shinyApp(ui, server = function(input, output, session) {})
#' }
choices_selected <- function(choices,
                             selected = if (inherits(choices, "delayed_data")) NULL else choices[1],
                             keep_order = FALSE,
                             fixed = FALSE) {
  stopifnot(is.atomic(choices) || inherits(choices, "delayed_data"))
  stopifnot(is.atomic(selected) || inherits(selected, "delayed_data") || inherits(selected, "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")) {
    out <- structure(
      list(choices = choices, selected = selected, keep_order = keep_order, fixed = fixed),
      class = c("delayed_choices_selected", "delayed_data", "choices_selected")
    )
    return(out)
  }

  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)

  if (!all(selected %in% choices)) {
    stop(paste(
      paste(
        selected[which(!selected %in% choices)],
        collapse = ", "
      ),
      "'selected' but not in '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"
  )
}

#' Check if an object is a choices_selected class.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x object to check
#' @rdname choices_selected
#' @export
is.choices_selected <- function(x) { # nolint
  inherits(x, "choices_selected")
}

#' Add empty choice to choices selected
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (\code{choices_selected}) output
#' @param multiple (\code{logical}) whether multiple selections are allowed or not
#'
#' @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
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (\code{character}) Word that shall be checked for
#'   NULL, empty, "--no-selection"
#'
#' @return the word or NULL
#'
#' @export
no_selected_as_NULL <- function(x) { # nolint
  if (is.null(x) || identical(x, no_select_keyword) || x == "") {
    NULL
  } else {
    x
  }
}

## Non-exported utils functions ----
## Modify vectors and keep attributes
vector_reorder <- function(vec, idx) {
  stopifnot(is.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

  return(vec)
}

vector_pop <- function(vec, idx) {
  stopifnot(is.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
  return(vec)
}

vector_remove_dups <- function(vec) {
  stopifnot(is.atomic(vec))

  idx <- which(duplicated(vec))

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

#' 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()].
#'
#' @param choices A character / factor / numeric / logical vector.
#' @param labels character vector containing labels to be applied to `choices`. If `NA` then
#' "Label Missing" will be used.
#' @param subset a vector that is a subset of `choices`. This is useful if
#'   only a few variables need to be named. If this argument is used, the returned vector will
#'   match its order.
#' @param types 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")
#' @details If either `choices` or `labels` are factors, they are coerced to character.
#' Duplicated elements from `choices` get removed.
#'
#' @return a named character vector
#'
#' @export
#'
#' @examples
#' library(shiny)
#'
#' ADSL <- teal.transform::rADSL
#' ADTTE <- teal.transform::rADTTE
#' choices1 <- choices_labeled(names(ADSL), teal.data::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),
#'   teal.data::col_labels(ADSL, fill = FALSE),
#'   subset = c("ARMCD", "ARM")
#' )
#' \dontrun{
#' shinyApp(
#'   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) {}
#' )
#' }
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]
  }
  choices <- structure(
    choices,
    names = combined_labels,
    raw_labels = raw_labels,
    combined_labels = combined_labels,
    class = c("choices_labeled", "character"),
    types = types
  )

  return(choices)
}


#' Wrapper on [choices_labeled] to label variables basing on existing labels in data
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param data (`data.frame`, `character`, `TealDataset`, `TealDatasetConnector`)
#' If `data.frame`, then data to extract labels from
#' If `character`, then name of the dataset to extract data from once available
#' If `TealDataset` or `TealDatasetConnector`, then raw data to extract labels from.
#' @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
#'
#' @rdname variable_choices
#'
#' @export
#'
#' @examples
#' 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 = teal.data::get_cdisc_keys("ADRS"))
#'
#' # delayed version
#' variable_choices("ADRS", subset = c("USUBJID", "STUDYID"))
#'
#' # also works with [teal.data::TealDataset] and [teal.data::TealDatasetConnector]
#' ADRS_dataset <- teal.data::dataset("ADRS", ADRS, key = teal.data::get_cdisc_keys("ADRS"))
#' variable_choices(ADRS_dataset)
#'
#' ADRS_conn <- teal.data::dataset_connector(
#'   "ADRS",
#'   pull_callable = teal.data::callable_code("radrs(cached = TRUE)"),
#'   key = teal.data::get_cdisc_keys("ADRS")
#' )
#' variable_choices(ADRS_conn)
#'
#' # functional subset (with delayed data) - return only factor variables
#' variable_choices("ADRS", subset = function(data) {
#'   idx <- vapply(data, is.factor, logical(1))
#'   return(names(data)[idx])
#' })
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) { # nolint

  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 <- stats::setNames(teal.slice:::variable_types(data = data), names(data))
  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)
  }

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

  return(res)
}

#' @rdname variable_choices
#' @export
variable_choices.TealDataset <- function(data, subset = NULL, fill = FALSE, key = teal.data::get_keys(data)) {
  variable_choices(
    data = teal.data::get_raw_data(data),
    subset = subset,
    fill = fill,
    key = key
  )
}

#' @rdname variable_choices
#' @export
variable_choices.TealDatasetConnector <- function(data, # nolint
                                                  subset = NULL,
                                                  fill = FALSE,
                                                  key = teal.data::get_keys(data)) {
  if (teal.data::is_pulled(data)) {
    variable_choices(
      data = teal.data::get_raw_data(data),
      subset = subset,
      fill = fill,
      key = key
    )
  } else {
    variable_choices(
      data = teal.data::get_dataname(data),
      subset = subset,
      fill = fill,
      key = key
    )
  }
}


#' Wrapper on [choices_labeled] to label variable values basing on other variable values
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param data (`data.frame`, `character`, `TealDataset`, `TealDatasetConnector`)
#' If `data.frame`, then data to extract labels from
#' If `character`, then name of the dataset to extract data from once available
#' If `TealDataset` or `TealDatasetConnector`, then raw data to extract labels from.
#' @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
#'
#' @rdname value_choices
#'
#' @export
#'
#' @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) {
#'   return(levels(data$PARAMCD)[1:2])
#' })
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 = " - ") {
  out <- 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")
  )
  return(out)
}

#' @rdname value_choices
#' @export
value_choices.data.frame <- function(data, # nolint
                                     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")),
      .fun = 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
  return(res)
}

#' @rdname value_choices
#' @export
value_choices.TealDataset <- function(data,
                                      var_choices,
                                      var_label = NULL,
                                      subset = NULL,
                                      sep = " - ") {
  value_choices(
    data = teal.data::get_raw_data(data),
    var_choices = var_choices,
    var_label = var_label,
    subset = subset,
    sep = sep
  )
}

#' @rdname value_choices
#' @export
value_choices.TealDatasetConnector <- function(data, # nolint
                                               var_choices,
                                               var_label = NULL,
                                               subset = NULL,
                                               sep = " - ") {
  if (teal.data::is_pulled(data)) {
    value_choices(
      data = teal.data::get_raw_data(data),
      var_choices = var_choices,
      var_label = var_label,
      subset = subset,
      sep = sep
    )
  } else {
    value_choices(
      data = teal.data::get_dataname(data),
      var_choices = var_choices,
      var_label = var_label,
      subset = subset,
      sep = sep
    )
  }
}
#' Print choices_labeled object
#' @description `r lifecycle::badge("stable")`
#' @rdname choices_labeled
#' @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"
  )

  return(invisible(x))
}

#' Merge expression module
#'
#' @description `r lifecycle::badge("experimental")`
#' @details This function is a convenient wrapper to combine `data_extract_multiple_srv()` and
#' `merge_expression_srv()` when no additional processing is required.
#' Compare the example below with that found in [merge_expression_srv()].
#'
#' @inheritParams shiny::moduleServer
#' @param datasets (named `list` of `reactive` or non-`reactive` `data.frame`)\cr
#'  object containing data as a list of `data.frame`. When passing a list of non-reactive `data.frame` objects, they are
#'  converted to reactive `data.frame` objects internally.
#' @param join_keys (`JoinKeys`)\cr
#'  of variables used as join keys for each of the datasets in `datasets`.
#'  This will be used to extract the `keys` of every dataset.
#' @param data_extract (named `list` of `data_extract_spec`)\cr
#' @param merge_function (`character(1)`)\cr
#'  A character string of a function that
#'  accepts the arguments `x`, `y` and `by` to perform the merging of datasets.
#' @param anl_name (`character(1)`)\cr
#'  Name of the analysis dataset.
#'
#' @return reactive expression with output from [merge_expression_srv()].
#'
#' @seealso [merge_expression_srv()]
#'
#' @examples
#' library(shiny)
#' ADSL <- data.frame(
#'   STUDYID = "A",
#'   USUBJID = LETTERS[1:10],
#'   SEX = rep(c("F", "M"), 5),
#'   AGE = rpois(10, 30),
#'   BMRKR1 = rlnorm(10)
#' )
#' ADLB <- expand.grid(
#'   STUDYID = "A",
#'   USUBJID = LETTERS[1:10],
#'   PARAMCD = c("ALT", "CRP", "IGA"),
#'   AVISIT = c("SCREENING", "BASELINE", "WEEK 1 DAY 8", "WEEK 2 DAY 15")
#' )
#' ADLB$AVAL <- rlnorm(120)
#' ADLB$CHG <- rnorm(120)
#'
#' data_list <- list(
#'   ADSL = ADSL,
#'   ADLB = ADLB
#' )
#'
#' join_keys <- teal.data::join_keys(
#'   teal.data::join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")),
#'   teal.data::join_key("ADSL", "ADLB", c("STUDYID", "USUBJID")),
#'   teal.data::join_key("ADLB", "ADLB", c("STUDYID", "USUBJID", "PARAMCD", "AVISIT"))
#' )
#'
#'
#' adsl_extract <- data_extract_spec(
#'   dataname = "ADSL",
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = c("AGE", "BMRKR1"),
#'     selected = "AGE",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#' adlb_extract <- data_extract_spec(
#'   dataname = "ADLB",
#'   filter = filter_spec(vars = "PARAMCD", choices = c("ALT", "CRP", "IGA"), selected = "ALT"),
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = c("AVAL", "CHG"),
#'     selected = "AVAL",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#' app <- shinyApp(
#'   ui = fluidPage(
#'     teal.widgets::standard_layout(
#'       output = div(
#'         verbatimTextOutput("expr"),
#'         dataTableOutput("data")
#'       ),
#'       encoding = tagList(
#'         data_extract_ui("adsl_var", label = "ADSL selection", adsl_extract),
#'         data_extract_ui("adlb_var", label = "ADLB selection", adlb_extract)
#'       )
#'     )
#'   ),
#'   server = function(input, output, session) {
#'     data_q <- teal.code::new_qenv()
#'
#'     data_q <- teal.code::eval_code(
#'       data_q,
#'       "ADSL <- data.frame(
#'         STUDYID = 'A',
#'         USUBJID = LETTERS[1:10],
#'         SEX = rep(c('F', 'M'), 5),
#'         AGE = rpois(10, 30),
#'         BMRKR1 = rlnorm(10)
#'       )"
#'     )
#'
#'     data_q <- teal.code::eval_code(
#'       data_q,
#'       "ADLB <- expand.grid(
#'         STUDYID = 'A',
#'         USUBJID = LETTERS[1:10],
#'         PARAMCD = c('ALT', 'CRP', 'IGA'),
#'         AVISIT = c('SCREENING', 'BASELINE', 'WEEK 1 DAY 8', 'WEEK 2 DAY 15'),
#'         AVAL = rlnorm(120),
#'         CHG = rlnorm(120)
#'        )"
#'     )
#'
#'     merged_data <- merge_expression_module(
#'       data_extract = list(adsl_var = adsl_extract, adlb_var = adlb_extract),
#'       datasets = data_list,
#'       join_keys = join_keys,
#'       merge_function = "dplyr::left_join"
#'     )
#'
#'     code_merge <- reactive({
#'       for (exp in merged_data()$expr) data_q <- teal.code::eval_code(data_q, exp)
#'       data_q
#'     })
#'
#'     output$expr <- renderText(paste(merged_data()$expr, collapse = "\n"))
#'     output$data <- renderDataTable(code_merge()[["ANL"]])
#'   }
#' )
#' \dontrun{
#' runApp(app)
#' }
#' @export
merge_expression_module <- function(datasets,
                                    join_keys = NULL,
                                    data_extract,
                                    merge_function = "dplyr::full_join",
                                    anl_name = "ANL",
                                    id = "merge_id") {
  logger::log_trace("merge_expression_module called with: { paste(names(datasets), collapse = ', ') } datasets.")
  checkmate::assert_list(data_extract, names = "named", types = c("list", "data_extract_spec", "NULL"))
  lapply(data_extract, function(x) {
    if (is.list(x) && !inherits(x, "data_extract_spec")) {
      checkmate::assert_list(x, "data_extract_spec")
    }
  })

  selector_list <- data_extract_multiple_srv(data_extract, datasets, join_keys)

  merge_expression_srv(
    id = id,
    selector_list = selector_list,
    datasets = datasets,
    join_keys = join_keys,
    merge_function = merge_function,
    anl_name = anl_name
  )
}


#' Data merge module server
#'
#' @description `r lifecycle::badge("experimental")`
#' @details When additional processing of the `data_extract` list input is required, `merge_expression_srv()` can be
#'   combined with `data_extract_multiple_srv()` or `data_extract_srv()` to influence the `selector_list` input.
#'   Compare the example below with that found in [merge_expression_module()].
#'
#' @inheritParams shiny::moduleServer
#' @param datasets (named `list` of `reactive` or non-`reactive` `data.frame`)\cr
#'  object containing data as a list of `data.frame`. When passing a list of non-reactive `data.frame` objects, they are
#'  converted to reactive `data.frame` objects internally.
#' @param join_keys (`JoinKeys`)\cr
#'  of variables used as join keys for each of the datasets in `datasets`.
#'  This will be used to extract the `keys` of every dataset.
#' @param selector_list (`reactive`)\cr
#'   output from [data_extract_multiple_srv()] or a reactive named list of outputs from [data_extract_srv()].
#'   When using a reactive named list, the names must be identical to the shiny ids of the respective
#'   [data_extract_ui()].
#' @param merge_function (`character(1)` or `reactive`)\cr
#'  A character string of a function that accepts the arguments
#'  `x`, `y` and `by` to perform the merging of datasets.
#' @param anl_name (`character(1)`)\cr
#'  Name of the analysis dataset.
#'
#' @return reactive expression with output from [merge_datasets()].
#'
#' @seealso [merge_expression_srv()]
#'
#' @export
#'
#' @examples
#' library(shiny)
#'
#' ADSL <- data.frame(
#'   STUDYID = "A",
#'   USUBJID = LETTERS[1:10],
#'   SEX = rep(c("F", "M"), 5),
#'   AGE = rpois(10, 30),
#'   BMRKR1 = rlnorm(10)
#' )
#'
#' ADLB <- expand.grid(
#'   STUDYID = "A",
#'   USUBJID = LETTERS[1:10],
#'   PARAMCD = c("ALT", "CRP", "IGA"),
#'   AVISIT = c("SCREENING", "BASELINE", "WEEK 1 DAY 8", "WEEK 2 DAY 15")
#' )
#' ADLB$AVAL <- rlnorm(120)
#' ADLB$CHG <- rlnorm(120)
#'
#' data_list <- list(
#'   ADSL = ADSL,
#'   ADLB = ADLB
#' )
#'
#' join_keys <- teal.data::join_keys(
#'   teal.data::join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")),
#'   teal.data::join_key("ADSL", "ADLB", c("STUDYID", "USUBJID")),
#'   teal.data::join_key("ADLB", "ADLB", c("STUDYID", "USUBJID", "PARAMCD", "AVISIT"))
#' )
#'
#' adsl_extract <- data_extract_spec(
#'   dataname = "ADSL",
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = c("AGE", "BMRKR1"),
#'     selected = "AGE",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#' adlb_extract <- data_extract_spec(
#'   dataname = "ADLB",
#'   filter = filter_spec(vars = "PARAMCD", choices = c("ALT", "CRP", "IGA"), selected = "ALT"),
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = c("AVAL", "CHG"),
#'     selected = "AVAL",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#'
#' app <- shinyApp(
#'   ui = fluidPage(
#'     teal.widgets::standard_layout(
#'       output = div(
#'         verbatimTextOutput("expr"),
#'         dataTableOutput("data")
#'       ),
#'       encoding = tagList(
#'         data_extract_ui("adsl_var", label = "ADSL selection", adsl_extract),
#'         data_extract_ui("adlb_var", label = "ADLB selection", adlb_extract)
#'       )
#'     )
#'   ),
#'   server = function(input, output, session) {
#'     data_q <- teal.code::new_qenv()
#'
#'     data_q <- teal.code::eval_code(
#'       data_q,
#'       "ADSL <- data.frame(
#'         STUDYID = 'A',
#'         USUBJID = LETTERS[1:10],
#'         SEX = rep(c('F', 'M'), 5),
#'         AGE = rpois(10, 30),
#'         BMRKR1 = rlnorm(10)
#'       )"
#'     )
#'
#'     data_q <- teal.code::eval_code(
#'       data_q,
#'       "ADLB <- expand.grid(
#'         STUDYID = 'A',
#'         USUBJID = LETTERS[1:10],
#'         PARAMCD = c('ALT', 'CRP', 'IGA'),
#'         AVISIT = c('SCREENING', 'BASELINE', 'WEEK 1 DAY 8', 'WEEK 2 DAY 15'),
#'         AVAL = rlnorm(120),
#'         CHG = rlnorm(120)
#'       )"
#'     )
#'
#'     selector_list <- data_extract_multiple_srv(
#'       list(adsl_var = adsl_extract, adlb_var = adlb_extract),
#'       datasets = data_list
#'     )
#'     merged_data <- merge_expression_srv(
#'       selector_list = selector_list,
#'       datasets = data_list,
#'       join_keys = join_keys,
#'       merge_function = "dplyr::left_join"
#'     )
#'
#'     code_merge <- reactive({
#'       for (exp in merged_data()$expr) data_q <- teal.code::eval_code(data_q, exp)
#'       data_q
#'     })
#'
#'     output$expr <- renderText(paste(merged_data()$expr, collapse = "\n"))
#'     output$data <- renderDataTable(code_merge()[["ANL"]])
#'   }
#' )
#' \dontrun{
#' runApp(app)
#' }
merge_expression_srv <- function(id = "merge_id",
                                 selector_list,
                                 datasets,
                                 join_keys,
                                 merge_function = "dplyr::full_join",
                                 anl_name = "ANL") {
  checkmate::assert_string(anl_name)
  stopifnot(make.names(anl_name) == anl_name)
  checkmate::assert_class(selector_list, "reactive")
  checkmate::assert_list(datasets, types = c("reactive", "data.frame"), names = "named")
  checkmate::assert_class(join_keys, "JoinKeys")

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

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

      reactive({
        checkmate::assert_list(selector_list(), names = "named", types = "reactive")
        merge_fun_name <- if (inherits(merge_function, "reactive")) merge_function() else merge_function
        check_merge_function(merge_fun_name)

        # function to filter out selectors which are NULL or only have validator
        f <- function(x) {
          is.null(x) || (length(names(x)) == 1 && names(x) == "iv")
        }

        ds <- Filter(Negate(f), lapply(selector_list(), function(x) x()))
        validate(need(length(ds) > 0, "At least one dataset needs to be selected"))
        merge_datasets(
          selector_list = ds,
          datasets = datasets,
          join_keys = join_keys,
          merge_function = merge_fun_name,
          anl_name = anl_name
        )
      })
    }
  )
}

check_data_extract_spec <- function(data_extract_spec) {
  if (is.null(data_extract_spec)) {
    return()
  }
  checkmate::assert_list(data_extract_spec, types = "data_extract_spec")
}

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`) the Shiny tag with the HTML code for the panel
#' @keywords internal
#' @examples
#' teal.transform:::cond_data_extract_single_ui(
#'   shiny::NS("TEST"),
#'   data_extract_spec(dataname = "test")
#' )
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")`
#' 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.
#'
#' There are three inputs that will be rendered
#' \enumerate{
#'  \item{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.
#'  }
#'  \item{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.
#'  }
#'  \item{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(...)`.
#'
#' @examples
#' library(shiny)
#'
#' 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
#' teal.widgets::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`)\cr
#'  object containing data either in the form of [teal.slice::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`)\cr
#'  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:
#'
#' \itemize{
#'   \item{`filters`: }{A list with the information on the filters that are applied to the data set.}
#'   \item{`select`: }{The variables that are selected from the dataset.}
#'   \item{`always_selected`: }{The column names from the data set that should always be selected.}
#'   \item{`reshape`: }{Whether reshape long to wide should be applied or not.}
#'   \item{`dataname`: }{The name of the data set.}
#'   \item{`internal_id`: }{The `id` of the corresponding shiny input element.}
#'   \item{`keys`: }{The names of the columns that can be used to merge the data set.}
#'   \item{`iv`:}{A `shinyvalidate::InputValidator` containing `validator` for this `data_extract`}
#' }
#'
#' @references [data_extract_srv]
#'
#' @export
#'
#' @examples
#'
#' library(shiny)
#' library(shinyvalidate)
#'
#' ADSL <- data.frame(
#'   STUDYID = "A",
#'   USUBJID = LETTERS[1:10],
#'   SEX = rep(c("F", "M"), 5),
#'   AGE = rpois(10, 30),
#'   BMRKR1 = rlnorm(10)
#' )
#'
#' 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 <- teal.data::join_keys(teal.data::join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")))
#'
#' app <- shinyApp(
#'   ui = fluidPage(
#'     teal.widgets::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()) {
#'   runApp(app)
#' }
#'
#' # Using FilteredData - Note this method will be deprecated
#' datasets <- teal.slice::init_filtered_data(
#'   list(ADSL = list(dataset = ADSL)),
#'   join_keys = teal.data::join_keys(
#'     teal.data::join_key("ADSL", "ADSL", c("USUBJID", "STUDYID"))
#'   )
#' )
#'
#' app <- shinyApp(
#'   ui = fluidPage(
#'     teal.widgets::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 = datasets,
#'       data_extract_spec = adsl_extract
#'     )
#'
#'     output$out1 <- renderPrint(adsl_reactive_input())
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
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 (`JoinKeys` 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)) { # nolint
                                    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, "JoinKeys", 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 (!is.null(join_keys)) {
        keys <- sapply(names(datasets), simplify = FALSE, function(x) join_keys$get(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.
#' This was suitable as input for (deprecated) [data_merge_srv()].
#'
#' @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.
#'
#' @export
#'
#' @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))
#'
#' app <- shinyApp(
#'   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()) {
#'   runApp(app)
#' }
data_extract_multiple_srv <- function(data_extract, datasets, ...) {
  checkmate::assert_list(data_extract, names = "named")
  lapply(data_extract, function(x) {
    if (is.list(x) && !inherits(x, "data_extract_spec")) {
      checkmate::assert_list(x, "data_extract_spec")
    }
  })
  checkmate::assert_multi_class(datasets, classes = c("FilteredData", "list"))
  UseMethod("data_extract_multiple_srv", datasets)
}

#' @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 (`JoinKeys` or `NULL`) of join keys per dataset in `datasets`.
#' @param select_validation_rule (`NULL`, `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`, `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`, `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)) { # nolint
                                             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, "JoinKeys", null.ok = TRUE)
  checkmate::assert(
    checkmate::check_multi_class(select_validation_rule, class = 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, class = 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, class = 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]]
        )
      }
    )
  })
}

#' Resolve delayed inputs by evaluating the code within the provided datasets
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x Object of class `delayed_data` to resolve.
#' @param datasets A named list of type `data.frame` to use for evaluation.
#' @param keys A named list of type `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.
#'
#' @examples
#' ADSL <- teal.transform::rADSL
#' attr(ADSL, "keys") <- teal.data::get_cdisc_keys("ADSL")
#' data_list <- list(ADSL = shiny::reactive(ADSL))
#' keys <- list(ADSL = attr(ADSL, "keys"))
#' shiny::isolate({
#'   # value_choices example
#'   v1 <- value_choices("ADSL", "SEX", "SEX")
#'   v1
#'   teal.transform:::resolve(v1, data_list, keys)
#'
#'   # variable_choices example
#'   v2 <- variable_choices("ADSL", c("BMRKR1", "BMRKR2"))
#'   v2
#'   teal.transform:::resolve(v2, data_list, keys)
#'
#'   # data_extract_spec example
#'   adsl_filter <- filter_spec(
#'     vars = variable_choices("ADSL", "SEX"),
#'     sep = "-",
#'     choices = value_choices("ADSL", "SEX", "SEX"),
#'     selected = "F",
#'     multiple = FALSE,
#'     label = "Choose endpoint and Censor"
#'   )
#'
#'   adsl_select <- select_spec(
#'     label = "Select variable:",
#'     choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
#'     selected = "BMRKR1",
#'     multiple = FALSE,
#'     fixed = FALSE
#'   )
#'
#'   adsl_de <- data_extract_spec(
#'     dataname = "ADSL",
#'     select = adsl_select,
#'     filter = adsl_filter
#'   )
#'
#'   teal.transform:::resolve(adsl_filter, data_list, keys)
#'   teal.transform:::resolve(adsl_select, data_list, keys)
#'   teal.transform:::resolve(adsl_de, data_list, keys)
#'
#'   # nested list (arm_ref_comp)
#'   arm_ref_comp <- list(
#'     ARMCD = list(
#'       ref = variable_choices("ADSL"),
#'       comp = variable_choices("ADSL")
#'     )
#'   )
#'
#'   teal.transform:::resolve(arm_ref_comp, data_list, keys)
#' })
resolve <- function(x, datasets, keys = NULL) {
  checkmate::assert_list(datasets, type = "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)
  )

  UseMethod("resolve")
}

#' @export
resolve.delayed_variable_choices <- function(x, datasets, keys) { # nolint
  if (is.null(x$key)) {
    x$key <- `if`(is.null(keys), character(), keys[[x$data]])
  }
  x$data <- datasets[[x$data]]()
  if (inherits(x$subset, "function")) {
    x$subset <- resolve_delayed_expr(x$subset, ds = x$data, is_value_choices = FALSE)
  }
  return(do.call("variable_choices", x))
}

#' @export
resolve.delayed_value_choices <- function(x, datasets, keys) { # nolint
  x$data <- datasets[[x$data]]()
  if (is.function(x$subset)) {
    x$subset <- resolve_delayed_expr(x$subset, ds = x$data, is_value_choices = TRUE)
  }
  return(do.call("value_choices", x))
}

#' @export
resolve.delayed_choices_selected <- function(x, datasets, keys) { # nolint
  if (inherits(x$selected, "delayed_data")) {
    x$selected <- resolve(x$selected, datasets = datasets, keys)
  }
  x$choices <- resolve(x$choices, datasets = datasets, keys)

  if (!all(x$selected %in% x$choices)) {
    logger::log_warn(paste(
      "Removing",
      paste(x$selected[which(!x$selected %in% x$choices)]),
      "from 'selected' as not in 'choices' when resolving delayed choices_selected"
    ))
    x$selected <- x$selected[which(x$selected %in% x$choices)]
  }

  return(do.call("choices_selected", x))
}

#' @export
resolve.delayed_select_spec <- function(x, datasets, keys) { # nolint
  x$choices <- resolve(x$choices, datasets = datasets, keys)
  if (inherits(x$selected, "delayed_data")) {
    x$selected <- resolve(x$selected, datasets = datasets, keys)
  }
  return(do.call("select_spec", x))
}

#' @export
resolve.delayed_filter_spec <- function(x, datasets, keys) { # nolint
  if (inherits(x$vars_choices, "delayed_data")) {
    x$vars_choices <- resolve(x$vars_choices, datasets = datasets, keys)
  }
  if (inherits(x$vars_selected, "delayed_data")) {
    x$vars_selected <- resolve(x$vars_selected, datasets = datasets, keys)
  }
  if (inherits(x$choices, "delayed_data")) {
    x$choices <- resolve(x$choices, datasets = datasets, keys)
  }
  if (inherits(x$selected, "delayed_data")) {
    x$selected <- resolve(x$selected, datasets = datasets, keys)
  }

  return(do.call("filter_spec_internal", x[intersect(names(x), methods::formalArgs(filter_spec_internal))]))
}

#' @export
resolve.delayed_data_extract_spec <- function(x, datasets, keys) { # nolint
  x$select <- `if`(
    inherits(x$select, "delayed_data"),
    resolve(x$select, datasets = datasets, keys),
    x$select
  )

  if (any(vapply(x$filter, inherits, logical(1L), "delayed_data"))) {
    idx <- vapply(x$filter, inherits, logical(1), "delayed_data")
    x$filter[idx] <- lapply(x$filter[idx], resolve, datasets = datasets, keys = keys)
  }

  return(do.call("data_extract_spec", x))
}

#' @export
resolve.list <- function(x, datasets, keys) { # nolint
  # If specified explicitly, return it unchanged. Otherwise if delayed, resolve.
  res <- lapply(x, resolve, datasets = datasets, keys = keys)
  return(res)
}

#' @export
resolve.default <- function(x, datasets, keys) {
  return(x)
}

#' Resolve expression after delayed data are loaded
#'
#'
#' @param x (`function`) Function that is applied on dataset.
#' It must take only a single argument "data" and return character vector with columns / values.
#' @param ds (`data.frame`) `TealDataset` on which the function is applied to.
#' @param is_value_choices (`logical`) Determines which check of the returned value will be applied.
#'
#' @return Character vector - result of calling function `x` on dataset `ds`.
#' @keywords internal
#'
#' @examples
#' \dontrun{
#' # get only possible factor variables from mtcars dataset
#' resolve_delayed_expr(
#'   function(data) {
#'     idx <- vapply(data, function(x) is.numeric(x) && length(unique(x)) <= 6, logical(1))
#'     colnames(data)[idx]
#'   },
#'   ds = mtcars,
#'   is_value_choices = FALSE
#' )
#' }
resolve_delayed_expr <- function(x, ds, is_value_choices) {
  checkmate::assert_function(x, args = "data", nargs = 1)

  # evaluate function
  res <- do.call(x, list(data = ds))

  # check returned value
  if (is_value_choices) {
    if (!is.atomic(res) || anyDuplicated(res)) {
      stop(paste(
        "The following function must return a vector with unique values",
        "from the respective columns of the dataset.\n\n",
        deparse1(bquote(.(x)), collapse = "\n")
      ))
    }
  } else {
    if (!checkmate::test_character(res, any.missing = FALSE) || length(res) > ncol(ds) || anyDuplicated(res)) {
      stop(paste(
        "The following function must return a character vector with unique",
        "names from the available columns of the dataset:\n\n",
        deparse1(bquote(.(x)), collapse = "\n")
      ))
    }
  }

  return(res)
}

#' @keywords internal
#' @export
print.delayed_variable_choices <- function(x, indent = 0L, ...) {
  cat(indent_msg(indent, paste("variable_choices with delayed data:", x$data)))
  cat("\n")
  print_delayed_list(x, indent)
  return(invisible(NULL))
}

#' @keywords internal
#' @export
print.delayed_value_choices <- function(x, indent = 0L, ...) {
  cat(indent_msg(indent, paste("value_choices with delayed data: ", x$data)))
  cat("\n")
  print_delayed_list(x, indent)
  return(invisible(NULL))
}

#' @keywords internal
#' @export
print.delayed_choices_selected <- function(x, indent = 0L, ...) {
  cat(indent_msg(indent, paste("choices_selected with delayed data: ", x$choices$data)))
  cat("\n")
  print_delayed_list(x, indent)
  return(invisible(NULL))
}

#' @keywords internal
#' @export
print.delayed_select_spec <- function(x, indent = 0L, ...) {
  cat(indent_msg(indent, paste("select_spec with delayed data:", x$choices$data)))
  cat("\n")
  print_delayed_list(x, indent)
  return(invisible(NULL))
}

#' @keywords internal
#' @export
print.filter_spec <- function(x, indent = 0L, ...) {
  cat(indent_msg(indent, "filter_spec with delayed data:"))
  cat("\n")
  print_delayed_list(x, indent)
  return(invisible(NULL))
}

#' @keywords internal
#' @export
print.delayed_filter_spec <- function(x, indent = 0L, ...) {
  cat(indent_msg(indent, "filter_spec with delayed data:"))
  cat("\n")
  print_delayed_list(x, indent)
  return(invisible(NULL))
}

#' @keywords internal
#' @export
print.delayed_data_extract_spec <- function(x, indent = 0L, ...) {
  cat(paste("data_extract_spec with delayed data:", x$dataname))
  cat("\n\n")
  print_delayed_list(x)
  return(invisible(NULL))
}

indent_msg <- function(n, msg) {
  checkmate::assert_integer(n, len = 1, lower = 0, any.missing = FALSE)
  checkmate::assert_character(msg, min.len = 1, any.missing = FALSE)
  indent <- paste(rep("  ", n), collapse = "")
  return(paste0(indent, msg))
}

print_delayed_list <- function(obj, n = 0L) {
  checkmate::assert_integer(n, len = 1, lower = 0, any.missing = FALSE)
  stopifnot(is.list(obj))

  for (idx in seq_along(obj)) {
    cat(indent_msg(n, ifelse(is.null(names(obj)[[idx]]), paste0("[[", idx, "]]"), paste("$", names(obj)[[idx]]))))
    cat("\n")
    if (inherits(obj[[idx]], "delayed_data")) {
      print(obj[[idx]], n + 1L)
    } else if (is.list(obj[[idx]])) {
      print_delayed_list(obj[[idx]], n + 1L)
    } else {
      cat(indent_msg(n, paste(utils::capture.output(print(obj[[idx]])), collapse = "\n")))
      cat("\n")
    }
  }
  return(invisible(NULL))
}

#' Returns a reactive list with values read from the inputs of `data_extract_spec`
#'
#' @details Reads the UI inputs of a single `data_extract_spec` object in
#' a running `teal` application. Returns a reactive list of reactive values
#' read from the input. The returned list has keys corresponding to the UI
#' inputs: `select`, `filters`, `always_selected`, `reshape`.
#'
#' @inheritParams data_extract_single_srv
#' @return `shiny::reactive` the reactive list with reactive values read from the UI
#' @keywords internal
#'
data_extract_read_srv <- function(id, datasets, single_data_extract_spec, iv, select_validation_rule = NULL,
                                  filter_validation_rule = NULL) {
  checkmate::assert_class(single_data_extract_spec, "data_extract_spec")
  checkmate::assert_list(datasets, types = "reactive", names = "named")
  moduleServer(
    id,
    function(input, output, session) {
      logger::log_trace(
        "data_extract_read_srv initialized with: { single_data_extract_spec$dataname } dataset."
      )
      filter_idx <- seq_along(single_data_extract_spec$filter)
      extract_n_process_inputs <- function(idx) {
        x <- single_data_extract_spec$filter[[idx]]
        input_col <- input[[paste0("filter", idx, ns.sep, "col")]]
        input_vals <- input[[paste0("filter", idx, ns.sep, "vals")]]
        # convert to numeric for class consistency because everything coming from input is character, e.g. "1"
        if (length(input_col) == 1L && is.numeric(datasets[[x$dataname]]()[[input_col]])) {
          input_vals <- as.numeric(input_vals)
        }
        for (col in input_col) {
          # replace NA with NA_character_ for class consistency
          if (any(vapply(input_vals, identical, logical(1), "NA")) &&
            anyNA(datasets[[x$dataname]]()[col]) &&
            !any(vapply(unique(datasets[[x$dataname]]()[col]), identical, logical(1), "NA"))) {
            input_vals[vapply(input_vals, identical, logical(1), "NA")] <- NA_character_
          }
        }

        selected <- split_by_sep(input_vals, x$sep)

        dn <- single_data_extract_spec$dataname
        cols <- `if`(length(input_col) > 0, paste(input_col, collapse = ", "), "NULL")
        sel <- `if`(length(selected) > 0, paste(selected, collapse = ", "), "NULL")
        logger::log_trace("data_extract_read_srv@1 dataname: { dn }; filter vars: { cols }; filter values: { sel }")

        list(
          columns = input_col,
          selected = selected,
          multiple = x$multiple,
          drop_keys = x$drop_keys
        )
      }

      r_filter <- eventReactive(
        ignoreNULL = FALSE,
        eventExpr = {
          lapply(
            filter_idx,
            function(idx) {
              input[[paste0("filter", idx, ns.sep, "vals")]]
            }
          )
        },
        valueExpr = {
          res <- if (length(single_data_extract_spec$filter) >= 1) {
            lapply(filter_idx, FUN = extract_n_process_inputs)
          }
          res
        }
      )

      if (!is.null(select_validation_rule)) {
        iv$add_rule("select", select_validation_rule)
      }

      if (!is.null(filter_validation_rule)) {
        for (idx in filter_idx) {
          iv$add_rule(
            paste0("filter", idx, ns.sep, "vals"),
            filter_validation_rule
          )
        }
      }

      tracked_input <- Queue$new()
      r_select <- eventReactive(
        ignoreNULL = FALSE,
        eventExpr = {
          input$select
          # Note that r_select reactivity is triggered by filter vals and not filter col.
          # This is intended since filter col updates filter vals which is then updating both r_filter and r_select.
          # If it depends on filter col then there will be two reactivity cycles:
          # (1) filter-col -> r_select -> read -> ... (2) filter-col -> filter-val -> r_filter -> read -> ...
          lapply(
            filter_idx,
            function(idx) {
              input[[paste0("filter", idx, shiny::ns.sep, "vals")]]
            }
          )
        },
        valueExpr = {
          if (isTRUE(single_data_extract_spec$select$ordered)) {
            shinyjs::runjs(
              sprintf(
                '$("#%s").parent().find("span.caret").removeClass("caret").addClass("fas fa-exchange-alt")',
                session$ns("select")
              )
            )
            tracked_input$remove(setdiff(tracked_input$get(), input$select))
            tracked_input$push(setdiff(input$select, tracked_input$get()))
            res <- tracked_input$get()
            res <- if (is.null(res)) character(0) else res
          } else {
            res <- if (is.null(input$select)) {
              if (is.null(single_data_extract_spec$select)) {
                as.character(unlist(lapply(
                  filter_idx,
                  function(idx) {
                    input[[paste0("filter", idx, ns.sep, "col")]]
                  }
                )))
              } else {
                character(0)
              }
            } else {
              input$select
            }

            if (!is.null(input$select_additional)) {
              res <- append(res, input$select_additional)
            }
            res
          }

          dn <- single_data_extract_spec$dataname
          sel <- `if`(length(res) > 0, paste(res, collapse = ", "), "NULL")
          logger::log_trace("data_extract_read_srv@2 dataname: { dn }; select: { sel }.")

          res
        }
      )

      r_reshape <- reactive({
        res <- if (is.null(input$reshape)) {
          FALSE
        } else {
          input$reshape
        }

        dn <- single_data_extract_spec$dataname
        resh <- paste(res, collapse = ", ")
        logger::log_trace("data_extract_read_srv@3 dataname: { dn }; reshape: { resh }.")

        res
      })

      reactive({
        list(
          filters = r_filter(),
          select = r_select(),
          always_selected = single_data_extract_spec$select$always_selected,
          reshape = r_reshape(),
          iv = iv
        )
      })
    }
  )
}

#' Checks `varname` argument and convert to call
#'
#' Checks `varname` type and parse if it's a `character`
#' @param varname (`name`, `call` or `character(1)`)\cr
#'   name of the variable
#' @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.
#'
#' @param varname (`name`, `call` or `character(1)`)\cr
#'   name of the variable
#'
#' @param choices (`vector`)\cr
#'   `varname` values to match using the `==` (single value) or
#'   `%in%` (vector) condition. `choices` can be vector of any type
#'   but for some output might be converted:
#'   \itemize{
#'     \item{`factor`}{ call is composed on choices converted to `character`}
#'     \item{`Date`}{ call is composed on choices converted to `character` using `format(choices)`}
#'     \item{`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 \code{\link{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`)
#'     }
#'   }
#'
#' @examples
#' teal.transform:::call_condition_choice("SEX", choices = c(1, 2))
#' teal.transform:::call_condition_choice(as.name("SEX"), choices = "F")
#' teal.transform:::call_condition_choice("SEX", choices = c("F", "M"))
#' teal.transform:::call_condition_choice("SEX", choices = factor(c("F", "M")))
#' teal.transform:::call_condition_choice("x$SEX", choices = Sys.Date())
#' teal.transform:::call_condition_choice("trunc(x$SEX)", choices = Sys.time())
#' @return a `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)`)\cr
#'   name of the variable
#'
#' @param range (`numeric(2)`)\cr
#'   range of the variable
#'
#' @return call
#' @examples
#' teal.transform:::call_condition_range("AGE", range = c(1, 2))
#' teal.transform:::call_condition_range(as.name("AGE"), range = c(-1.2, 2.1))
#' teal.transform:::call_condition_range(
#'   teal.transform:::call_extract_list("ADSL", "AGE"),
#'   range = c(-1.2, 2.1)
#' )
#' @return a `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)`)\cr
#'   name of the variable
#'
#' @param choice (`logical(1)`)\cr
#'   chosen value
#'
#' @return call
#' @examples
#' teal.transform:::call_condition_logical("event", choice = TRUE)
#' teal.transform:::call_condition_logical("event", choice = FALSE)
#' @return a `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)`)\cr
#'   name of the variable
#'
#' @param range (`POSIXct`)\cr
#'   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)`)\cr
#'   specifies the time zone to be used for the conversion.
#'   By default `Sys.timezone()` is used.
#'
#' @examples
#' teal.transform:::call_condition_range_posixct(
#'   varname = as.name("datetime"),
#'   range = c(Sys.time(), Sys.time() + 1),
#'   timezone = "UTC"
#' )
#' @return a `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)`)\cr
#'   name of the variable
#'
#' @param range (`Date`)\cr
#'   range of the variable
#'
#' @examples
#' teal.transform:::call_condition_range_date(
#'   as.name("date"),
#'   range = c(Sys.Date(), Sys.Date() + 1)
#' )
#' @return a `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
#'
#' Get call to subset and select array
#' @param dataname (`character(1)` or `name`)\cr
#' @param row (`name`, `call`, `logical`, `integer`, `character`)\cr
#'   optional, name of the `row` or condition
#' @param column (`name`, `call`, `logical`, `integer`, `character`)\cr
#'   optional, name of the `column` or condition
#' @param aisle (`name`, `call`, `logical`, `integer`, `character`)\cr
#'   optional, name of the `row` or condition
#' @return `[` call with all conditions included
#' @examples
#' teal.transform:::call_extract_array(
#'   dataname = "my_array",
#'   row = teal.transform:::call_condition_choice("my_array$SEX", "M"),
#'   column = call("c", "SEX", "AGE"),
#'   aisle = "RNAseq_rnaaccess"
#' )
#' teal.transform:::call_extract_array(
#'   "mae_object",
#'   column = teal.transform:::call_condition_choice("SEX", "M")
#' )
#' @return specific \code{\link[base]{Extract}} `call` for 3-dimensional array
#' @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
#'
#' Get call to subset and select matrix
#' @param dataname (`character(1)` or `name`)\cr
#' @param row (`name`, `call`, `logical`, `integer`, `character`)\cr
#'   optional, name of the `row` or condition
#' @param column (`name`, `call`, `logical`, `integer`, `character`)\cr
#'   optional, name of the `column` or condition
#' @return `[` call with all conditions included
#' @examples
#' teal.transform:::call_extract_matrix(
#'   dataname = "my_array",
#'   row = teal.transform:::call_condition_choice("my_array$SEX", "M"),
#'   column = call("c", "SEX", "AGE")
#' )
#' teal.transform:::call_extract_matrix(
#'   "mae_object",
#'   column = teal.transform:::call_condition_choice("SEX", "M")
#' )
#' @return specific \code{\link[base]{Extract}} `call` for matrix
#' @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
#'
#' Compose extract call with `$` operator
#'
#' @param dataname (`character(1)` or `name`)\cr
#'   name of the object
#'
#' @param varname (`character(1)` or `name`)\cr
#'   name of the slot in data
#'
#' @param dollar (`logical(1)`)\cr
#'   whether returned call should use `$` or `[[` operator
#'
#' @return `$` or `[[` call
#' @examples
#' teal.transform:::call_extract_list("ADSL", "SEX")
#' teal.transform:::call_extract_list("ADSL", "named element")
#' teal.transform:::call_extract_list(as.name("ADSL"), as.name("AGE"))
#' teal.transform:::call_extract_list(as.name("weird name"), as.name("AGE"))
#' teal.transform:::call_extract_list(as.name("ADSL"), "AGE", dollar = FALSE)
#' @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 arguments in ... need to be quoted because they will be evaluated otherwise
#'
#' @md
#' @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
#' @examples
#'
#' print_call_and_eval <- function(x) {
#'   eval(print(x))
#' }
#'
#' print_call_and_eval(
#'   teal.transform:::call_with_colon("glue::glue", "x = {x}", x = 10)
#' )
#' \dontrun{
#' # mtcars$cyl evaluated
#' print_call_and_eval(
#'   teal.transform:::call_with_colon("dplyr::filter", as.name("mtcars"), mtcars$cyl == 6)
#' )
#'
#' # mtcars$cyl argument not evaluated immediately (in call expression)
#' print_call_and_eval(
#'   teal.transform:::call_with_colon("dplyr::filter", as.name("mtcars"), quote(cyl == 6))
#' )
#'
#' # does not work because argument is evaluated and the
#' # non-dplyr filter does not look inside mtcars
#' # cannot eval because it does not pass checks because of non-standard evaluation
#' call("filter", as.name("mtcars"), quote(cyl == 6))
#' # works, but non-dplyr filter is taken
#' call("filter", as.name("mtcars"), mtcars$cyl == 6)
#'
#' nb_args <- function(...) nargs()
#' print_call_and_eval(
#'   teal.transform:::call_with_colon("nb_args", arg1 = 1, unlist_args = list(arg2 = 2, args3 = 3))
#' )
#' # duplicate arguments
#' print_call_and_eval(
#'   teal.transform:::call_with_colon("nb_args", arg1 = 1, unlist_args = list(arg2 = 2, args2 = 2))
#' )
#' }
#' @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`)\cr
#'   name/symbol of the operator.
#'
#' @param calls (`list` of calls)\cr
#'   list containing calls to be combined by `operator`
#'
#' @return call
#' @examples
#' teal.transform:::calls_combine_by(
#'   "&",
#'   calls = list(
#'     teal.transform:::call_condition_choice("SEX", "F"),
#'     teal.transform:::call_condition_range("AGE", c(20, 50)),
#'     teal.transform:::call_condition_choice("ARM", "ARM: A"),
#'     TRUE
#'   )
#' )
#' @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)
  )
}

#' Returns a `shiny.tag` with the UI elements for a `data_extract_spec`
#'
#' @details Creates a `shiny.tag` element defining the UI elements corresponding
#' a single `data_extract_spec` object.
#'
#' @param id (`character(1)`) the id of the module
#' @param single_data_extract_spec (`data_extract_spec`) the [data_extract_spec()] object to handle.
#'
#' @return `shiny.tag` the HTML element defining the UI
#' @keywords internal
#'
#' @examples
#' teal.transform:::data_extract_single_ui(id = "test", data_extract_spec("extract"))
data_extract_single_ui <- function(id = NULL, single_data_extract_spec) {
  stopifnot(inherits(single_data_extract_spec, "data_extract_spec"))
  ns <- NS(id)

  ## filter input
  extract_spec_filter <- single_data_extract_spec$filter
  filter_display <- do.call(
    div,
    lapply(
      seq_along(extract_spec_filter),
      function(idx) {
        x <- extract_spec_filter[[idx]]
        if (inherits(x, "filter_spec")) {
          data_extract_filter_ui(filter = x, id = ns(paste0("filter", idx)))
        } else {
          stop("Unsupported object class")
        }
      }
    )
  )

  ## select input
  extract_spec_select <- single_data_extract_spec$select
  if (!is.null(extract_spec_select$fixed)) {
    attr(extract_spec_select$fixed, which = "dataname") <- single_data_extract_spec$dataname
  }

  select_display <- if (is.null(extract_spec_select)) {
    NULL
  } else {
    data_extract_select_ui(extract_spec_select, id = ns("select"))
  }

  ## reshape input
  extract_spec_reshape <- single_data_extract_spec$reshape
  reshape_display <- checkboxInput(
    inputId = ns("reshape"),
    label = "Reshape long to wide format",
    value = extract_spec_reshape
  )
  # always disable reshape button and hide if it is not pre-configured
  reshape_display <- shinyjs::disabled(reshape_display)
  if (!extract_spec_reshape) reshape_display <- shinyjs::hidden(reshape_display)

  ## all combined
  div(filter_display, select_display, reshape_display)
}

#' The server function for a single `data_extract_spec` object
#'
#' @details The Shiny server function for handling a single
#' [data_extract_spec] object.
#'
#' @inheritParams data_extract_filter_srv
#' @inheritParams data_extract_single_ui
#'
#' @return `NULL`
#' @keywords internal
data_extract_single_srv <- function(id, datasets, single_data_extract_spec) {
  moduleServer(
    id,
    function(input, output, session) {
      logger::log_trace(
        "data_extract_single_srv initialized with dataset: { single_data_extract_spec$dataname }."
      )
      for (idx in seq_along(single_data_extract_spec$filter)) {
        x <- single_data_extract_spec$filter[[idx]]
        if (inherits(x, "filter_spec")) {
          data_extract_filter_srv(
            id = paste0("filter", idx),
            datasets = datasets,
            filter = x
          )
        }
        NULL
      }
    }
  )
}

#' 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 (\code{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, "JoinKeys")
  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
      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
#'
#' Parse filter, select, rename and reshape call
#' @inheritParams get_dplyr_call_data
#' @param idx optional (\code{integer}) current selector index in all selectors list
#' @param dplyr_call_data (\code{list}) simplified selectors with aggregated set of filters,
#'   selections, reshapes etc. All necessary data for merging
#' @param data (`NULL` or named `list`).
#'
#' @return (\code{call}) filter, select, rename and reshape call
#' @keywords internal
#'
#' @examples
#' # one dataset
#' teal.transform:::get_dplyr_call(
#'   list(list(
#'     dataname = "ADSL",
#'     filters = NULL,
#'     select = character(0),
#'     keys = teal.data::get_cdisc_keys("ADSL"),
#'     reshape = FALSE,
#'     internal_id = "test1"
#'   ))
#' )
#' teal.transform:::get_dplyr_call(
#'   list(list(
#'     dataname = "ADSL",
#'     filters = list(list(columns = "SEX", selected = list("F", "M"))),
#'     select = character(0),
#'     keys = teal.data::get_cdisc_keys("ADSL"),
#'     reshape = FALSE,
#'     internal_id = "test1"
#'   ))
#' )
#' teal.transform:::get_dplyr_call(
#'   list(list(
#'     dataname = "ADSL",
#'     filters = list(list(columns = "SEX", selected = list("F", "M"))),
#'     select = c("AVAL"),
#'     keys = teal.data::get_cdisc_keys("ADSL"),
#'     reshape = FALSE,
#'     internal_id = "test1"
#'   ))
#' )
#'
#' # two datasets with rename part
#' teal.transform:::get_dplyr_call(
#'   list(
#'     list(
#'       dataname = "ADSL",
#'       filters = NULL,
#'       select = c("COL_1", "COL_2"),
#'       keys = teal.data::get_cdisc_keys("ADSL"),
#'       reshape = FALSE,
#'       internal_id = "test1"
#'     ),
#'     list(
#'       dataname = "ADSL",
#'       filters = NULL,
#'       select = c("COL_2", "COL_3"),
#'       keys = teal.data::get_cdisc_keys("ADSL"),
#'       reshape = FALSE,
#'       internal_id = "test2"
#'     )
#'   ),
#'   idx = 1L
#' )
#'
#' # long dataset with reshape part
#' teal.transform:::get_dplyr_call(
#'   list(list(
#'     dataname = "ADLB",
#'     filters = list(list(
#'       columns = c("PARAMCD", "AVISIT"),
#'       selected = list(c("ALBCV", "SCREENING"), c("ALBCV", "BASELINE"))
#'     )),
#'     select = c("AVAL"),
#'     keys = teal.data::get_cdisc_keys("ADLB"),
#'     reshape = TRUE,
#'     internal_id = "test1"
#'   ))
#' )
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, "JoinKeys", 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
  }

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

  return(final_call)
}

#' Parse \code{dplyr} select call
#'
#' @param select (\code{character}) vector of selected column names
#'
#' @return (\code{call}) \code{dplyr} select call
#' @keywords internal
#'
#' @examples
#' teal.transform:::get_select_call(letters)
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)))
}

#' Returns \code{dplyr} filter call
#'
#' @param filter (\code{list}) Either list of lists or list with \code{select} and \code{selected} items.
#' @param dataname (\code{NULL} or \code{character}) name of dataset.
#' @param datasets (\code{NULL} or \code{named `list`}).
#' @return (\code{call}) \code{dplyr} filter call
#' @keywords internal
#'
#' @examples
#' teal.transform:::get_filter_call(
#'   filter = list(list(columns = "SEX", selected = list(NA, "F", "M")))
#' )
#' teal.transform:::get_filter_call(filter = list(
#'   list(columns = "SEX", selected = list(NA, "F", "M")),
#'   list(columns = "VAR", selected = list("LEVEL1", "LEVEL2"))
#' ))
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
  }
}

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 \code{dplyr} rename call
#'
#' Rename is used only if there are duplicated columns
#'
#' @inheritParams get_dplyr_call
#'
#' @return (\code{call}) \code{dplyr} rename call
#' @keywords internal
#' @references get_rename_dict
#'
#' @examples
#' x <- list(
#'   list(
#'     dataname = "ADSL",
#'     filters = NULL,
#'     select = utils::head(letters, 3),
#'     keys = teal.data::get_cdisc_keys("ADSL"),
#'     reshape = FALSE,
#'     internal_id = "test1"
#'   ),
#'   list(
#'     dataname = "ADSL",
#'     filters = NULL,
#'     select = letters,
#'     keys = teal.data::get_cdisc_keys("ADSL"),
#'     reshape = FALSE,
#'     internal_id = "test2"
#'   ),
#'   list(
#'     dataname = "ADSL",
#'     filters = NULL,
#'     select = utils::tail(letters, 3),
#'     keys = teal.data::get_cdisc_keys("ADSL"),
#'     reshape = FALSE,
#'     internal_id = "test3"
#'   ),
#'   list(
#'     dataname = "ADSL",
#'     filters = NULL,
#'     select = c("aa", "bb"),
#'     keys = teal.data::get_cdisc_keys("ADSL"),
#'     reshape = FALSE,
#'     internal_id = "test4"
#'   )
#' )
#' teal.transform:::get_rename_call(x, 1L)
#' teal.transform:::get_rename_call(x, 2L)
#' teal.transform:::get_rename_call(x, 3L)
#' teal.transform:::get_rename_call(x, 4L)
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 \code{dplyr} reshape call
#'
#' @inheritParams get_dplyr_call
#'
#' @return (\code{list}) list of multiple \code{dplyr} calls that reshape data
#' @keywords internal
#'
#' @examples
#' filters <- list(
#'   columns = c("PARAMCD", "AVISIT"),
#'   selected = list(c("ALT", "SCREENING"), c("ALT", "BASELINE"))
#' )
#' select <- "AVAL"
#' internal_id <- "ADLB"
#'
#' x <- list(
#'   list(
#'     dataname = "ADLB",
#'     filters = list(list(
#'       columns = c("PARAMCD", "AVISIT"),
#'       selected = list(c("ALBCV", "SCREENING"), c("ALBCV", "BASELINE")),
#'       multiple = FALSE
#'     )),
#'     select = "AVAL",
#'     keys = teal.data::get_cdisc_keys("ADLB"),
#'     reshape = TRUE,
#'     internal_id = "test"
#'   )
#' )
#' teal.transform:::get_reshape_call(x, 1L)
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 \code{get_dplyr_call_data}.
#' @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 \code{filter_spec}.
#' @inheritParams get_pivot_longer_col
#' @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
#' @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]

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

  res
}

#' Column selection input specification
#'
#' @description `r lifecycle::badge("stable")`
#' \code{select_spec} is used inside teal to create a \code{\link[shiny]{selectInput}}
#' that will select columns from a dataset.
#'
#' @param choices (\code{character}) or (\code{delayed_data}) object.
#'   Named character vector to define the choices
#'   of a shiny \code{\link[shiny]{selectInput}}. These have to be columns in the
#'   dataset defined in the \code{\link{data_extract_spec}} where this is called.
#'   \code{delayed_data} objects can be created via \code{\link{variable_choices}} or \code{\link{value_choices}}.
#'
#' @param selected optional (\code{character} or \code{NULL} or \code{all_choices} or \code{delayed_data} object).
#' Named character vector to define the selected values of a shiny \code{\link[shiny]{selectInput}}.
#' Passing an `all_choices()` object indicates selecting all possible choices.
#' Defaults to the first value of \code{choices} or \code{NULL} for delayed data loading.
#'
#' @param multiple (\code{logical}) Whether multiple values shall be allowed in the
#'  shiny \code{\link[shiny]{selectInput}}.
#'
#' @param fixed optional (\code{logical}). \code{\link{data_extract_spec}} specific feature to
#'   hide the choices selected in case they are not needed. Setting fixed to \code{TRUE}
#'   will not allow the user to select columns. It will then lead to a selection of
#'   columns in the dataset that is defined by the developer of the app.
#'
#' @param always_selected (\code{character}) Additional column names from the data set that should
#'   always be selected
#'
#' @param ordered (`logical(1)`) Flags whether selection order should be tracked.
#'
#' @param label optional (\code{character}). Define a label on top of this specific
#' shiny \code{\link[shiny]{selectInput}}. The default value is \code{"Select"}.
#'
#' @return A \code{select_spec}-S3 class object or \code{delayed_select_spec}-S3-class object.
#' It contains all input values.
#' If \code{select_spec}, then the function double checks the \code{choices} and \code{selected} inputs.
#'
#'
#' @rdname select_spec
#'
#' @export
#'
#' @examples
#' # Selection with just one column allowed
#' select_spec(
#'   choices = c("AVAL", "BMRKR1", "AGE"),
#'   selected = c("AVAL"),
#'   multiple = FALSE,
#'   fixed = FALSE,
#'   label = "Column"
#' )
#'
#' # Selection with just multiple columns allowed
#' select_spec(
#'   choices = c("AVAL", "BMRKR1", "AGE"),
#'   selected = c("AVAL", "BMRKR1"),
#'   multiple = TRUE,
#'   fixed = FALSE,
#'   label = "Columns"
#' )
#'
#' # Selection without user access
#' select_spec(
#'   choices = c("AVAL", "BMRKR1"),
#'   selected = c("AVAL", "BMRKR1"),
#'   multiple = TRUE,
#'   fixed = TRUE,
#'   label = "Columns"
#' )
#'
#' # Delayed version
#' select_spec(
#'   label = "Select variable:",
#'   choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
#'   selected = "BMRKR1",
#'   multiple = FALSE,
#'   fixed = FALSE
#' )
#'
#' # all_choices passed to selected
#' select_spec(
#'   label = "Select variable:",
#'   choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
#'   selected = all_choices()
#' )
#'
#' # Both below objects are semantically the same
#' select_spec(choices = variable_choices("ADSL"), selected = variable_choices("ADSL"))
#' select_spec(choices = variable_choices("ADSL"), selected = all_choices())
select_spec <- function(choices,
                        selected = `if`(inherits(choices, "delayed_data"), NULL, choices[1]),
                        multiple = length(selected) > 1 || inherits(selected, "all_choices"),
                        fixed = FALSE,
                        always_selected = NULL,
                        ordered = FALSE,
                        label = "Select") {
  checkmate::assert_flag(multiple)
  checkmate::assert_flag(fixed)
  checkmate::assert_character(always_selected, min.len = 1, null.ok = TRUE, any.missing = FALSE)
  checkmate::assert_flag(ordered)
  checkmate::assert_string(label, null.ok = TRUE)
  stopifnot(multiple || !inherits(selected, "all_choices"))
  if (fixed) stopifnot(is.null(always_selected))

  if (inherits(selected, "all_choices")) selected <- choices
  if (inherits(choices, "delayed_data") || inherits(selected, "delayed_data")) {
    select_spec.delayed_data(choices, selected, multiple, fixed, always_selected, ordered, label)
  } else {
    select_spec.default(choices, selected, multiple, fixed, always_selected, ordered, label)
  }
}

#' @rdname select_spec
#' @export
select_spec.delayed_data <- function(choices, # nolint
                                     selected = NULL,
                                     multiple = length(selected) > 1,
                                     fixed = FALSE,
                                     always_selected = NULL,
                                     ordered = FALSE,
                                     label = NULL) {
  stopifnot(is.null(selected) || is.atomic(selected) || inherits(selected, "delayed_data"))
  stopifnot(is.null(choices) || is.atomic(choices) || inherits(choices, "delayed_data"))

  structure(
    list(
      choices = choices,
      selected = selected,
      multiple = multiple,
      fixed = fixed,
      always_selected = always_selected,
      ordered = ordered,
      label = label
    ),
    class = c("delayed_select_spec", "delayed_data", "select_spec")
  )
}

#' @rdname select_spec
#' @export
select_spec.default <- function(choices, # nolint
                                selected = choices[1],
                                multiple = length(selected) > 1,
                                fixed = FALSE,
                                always_selected = NULL,
                                ordered = FALSE,
                                label = NULL) {
  stopifnot(is.null(choices) || is.atomic(choices))
  stopifnot(is.null(selected) || is.atomic(selected))

  # if names is NULL, shiny will put strange labels (with quotes etc.) in the selectInputs, so we set it to the values
  if (is.null(names(choices))) {
    names(choices) <- as.character(choices)
  }

  # Deal with selected
  if (length(selected) > 0) {
    stopifnot(is.atomic(selected))
    stopifnot(all(selected %in% choices))
    stopifnot(multiple || length(selected) == 1)
    if (is.null(names(selected))) {
      names(selected) <- as.character(selected)
    }
  }

  if (length(intersect(choices, always_selected)) > 0) {
    warning("You cannot allow the user to select 'always_selected' columns.
      'choices' and 'always_selected' will be intersected")
    test_c <- choices[which(!choices %in% always_selected)]
    if (length(test_c) > 0) {
      class(test_c) <- c("choices_labeled", "character")
      choices <- test_c
    } else {
      choices <- NULL
    }
  }

  res <- list(
    choices = choices, selected = selected, multiple = multiple, fixed = fixed,
    always_selected = always_selected, ordered = ordered, label = label
  )
  class(res) <- "select_spec"

  return(res)
}

#' Returns non-key column names from data
#'
#' @description `r lifecycle::badge("stable")`
#' @export
#'
#' @param data (\code{data.frame}) Data with attribute \code{filter_and_columns}. This can only be
#'  created by \code{\link{data_extract_srv}}. which returns a shiny \code{\link[shiny]{reactive}}.
#'
#' @return A named character vector with the non-key columns of the \code{data}..
#'
#' @references \link{data_extract_srv}
get_dataset_prefixed_col_names <- function(data) {
  if (!is.null(attr(data, "filter_and_columns")$columns) && attr(data, "filter_and_columns")$columns != "") {
    paste(attr(data, "dataname"), attr(data, "filter_and_columns")$columns, sep = ".")
  } else {
    NULL
  }
}

#' Data extract filter specification
#'
#' @description `r lifecycle::badge("stable")`
#' It consists in choices and additionally the variable names for the choices
#'
#' @export
#'
#' @inheritParams select_spec
#'
#' @param vars (\code{character}) or (\code{delayed_data}) object.
#'   Character vector giving the columns to be filtered. These should be
#'   key variables of the data set to be filtered.
#'   \code{delayed_data} objects can be created via [variable_choices()], [value_choices()],
#'   or \code{\link{choices_selected}}.
#' @param sep (\code{character}) A separator string to split the \code{choices} or
#'   \code{selected} inputs into the values of the different columns
#' @param choices (\code{character} or \code{numeric} or \code{logical} or (\code{delayed_data}) object.
#'   Named character vector to define the choices
#'   of a shiny \code{\link[shiny]{selectInput}}. These choices will be used to filter the
#'   dataset.
#'
#'   These shall be filter values of the \code{vars} input separated by the separator(\code{sep}). Please
#'   watch out that the filter values have to follow the order of the \code{vars} input. In the following
#'   example we will show how to filter two columns:
#'
#'   \code{vars = c("PARAMCD","AVISIT")} and \code{choices = c("CRP - BASELINE", "ALT - BASELINE")}
#'   will lead to a filtering of
#'   \code{(PARAMCD == "CRP" & AVISIT == "BASELINE") | (PARAMCD == "ALT" & AVISIT == "BASELINE")}.
#'
#'   The \code{sep} input has to be \code{" - "} in this case.
#'
#'   \code{delayed_data} objects can be created via \code{\link{variable_choices}} or \code{\link{value_choices}}.
#'
#' @param selected (\code{character} or \code{numeric} or \code{logical} or
#'  (\code{delayed_data} or (\code{all_choices})) object.
#'  Named character vector to define the selected
#'  values of a shiny \code{\link[shiny]{selectInput}} (default values). This value will
#'  be displayed inside the shiny app upon start. The `all_choices` object indicates selecting
#'  all possible choices.
#'
#' @param drop_keys optional, (\code{logical}) whether to drop filter column from the dataset keys,
#'   \code{TRUE} on default.
#'
#' @param label optional (\code{character}). Define a label on top of this specific
#' shiny \code{\link[shiny]{selectInput}}. The default value is \code{"Filter by"}.
#'
#' @return \code{filter_spec}-S3-class object or \code{delayed_filter_spec}-S3-class object.
#'
#' @details
#'
#' The \code{filter_spec} is used inside \code{teal} apps to allow filtering datasets
#' for their key variables. Imagine having an adverse events table. It has
#' the columns \code{PARAMCD} and \code{CNSR}. \code{PARAMCD} contains the levels
#' \code{"OS"}, \code{"PFS"}, \code{"EFS"}. \code{CNSR} contains the levels \code{"0"} and \code{"1"}.
#' The first example should show how a \code{filter_spec} setup will influence
#' the drop-down menu the app user will see.
#'
#'
#' @examples
#' # for Adverse Events table
#' 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"
#' )
#'
#' # filtering a single variable
#' filter_spec(
#'   vars = c("PARAMCD"),
#'   sep = "-",
#'   choices = c("OS", "PFS", "EFS"),
#'   selected = "OS",
#'   multiple = FALSE,
#'   label = "Choose endpoint"
#' )
#'
#' # filtering a single variable by multiple levels of the variable
#' filter_spec(
#'   vars = c("PARAMCD"),
#'   sep = "-",
#'   choices = c("OS", "PFS", "EFS"),
#'   selected = c("OS", "PFS"),
#'   multiple = TRUE,
#'   label = "Choose endpoint"
#' )
#'
#' # delayed version
#' filter_spec(
#'   vars = variable_choices("ADSL", "SEX"),
#'   sep = "-",
#'   choices = value_choices("ADSL", "SEX", "SEX"),
#'   selected = "F",
#'   multiple = FALSE,
#'   label = "Choose endpoint and Censor"
#' )
#' # using `choices_selected()`
#' filter_spec(
#'   vars = choices_selected(variable_choices("ADSL", subset = c("SEX", "AGE")), "SEX", fixed = FALSE),
#'   multiple = TRUE
#' )
#'
#' filter_spec(
#'   vars = choices_selected(variable_choices("ADSL"), "SEX", fixed = TRUE),
#'   multiple = TRUE
#' )
#'
#' # choose all choices
#' adsl_filter <- filter_spec(
#'   vars = choices_selected(variable_choices("ADSL"), "SEX", fixed = FALSE),
#'   choices = value_choices("ADSL", "SEX"),
#'   selected = all_choices()
#' )
filter_spec <- function(vars,
                        choices = NULL,
                        selected = `if`(inherits(choices, "delayed_data"), NULL, choices[1]),
                        multiple = length(selected) > 1 || inherits(selected, "all_choices"),
                        label = "Filter by",
                        sep = attr(choices, "sep"),
                        drop_keys = FALSE) {
  if (is.null(sep)) sep <- " - "
  checkmate::assert(
    checkmate::check_character(vars, min.len = 1, any.missing = FALSE),
    checkmate::check_class(vars, "delayed_data"),
    checkmate::check_class(vars, "choices_selected")
  )
  checkmate::assert(
    checkmate::check_null(choices),
    checkmate::check_character(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_class(choices, "delayed_data")
  )
  checkmate::assert(
    checkmate::check_null(selected),
    checkmate::check_character(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_class(selected, "delayed_data"),
    checkmate::check_class(selected, "all_choices")
  )

  checkmate::assert_flag(multiple)
  checkmate::assert_string(label, null.ok = TRUE)
  checkmate::assert_string(sep)
  checkmate::assert_flag(drop_keys)
  stopifnot(multiple || !inherits(selected, "all_choices"))

  if (inherits(selected, "all_choices") && !is.null(choices)) selected <- choices

  if (inherits(vars, "choices_selected")) {
    filter_spec_internal(
      vars_choices = vars$choices,
      vars_selected = vars$selected,
      vars_label = if (vars$fixed) NULL else label,
      vars_fixed = vars$fixed,
      vars_multiple = if (is.null(vars$selected)) FALSE else length(vars$selected) > 1,
      choices = choices,
      selected = selected,
      label = if (vars$fixed) label else NULL,
      fixed = FALSE,
      multiple = multiple,
      sep = sep,
      drop_keys = drop_keys
    )
  } else {
    filter_spec_internal(
      vars_choices = vars,
      vars_selected = vars,
      vars_label = NULL,
      vars_fixed = TRUE,
      vars_multiple = TRUE,
      choices = choices,
      selected = selected,
      label = label,
      fixed = FALSE,
      multiple = multiple,
      sep = sep,
      drop_keys = drop_keys
    )
  }
}


#' Data extract dynamic filter specification
#'
#' This function returns a configuration for the \code{data_extract_ui} module. This function covers
#' the configuration of filtering datasets (so called `filter_spec`), which then is used to build
#' the UI element in the `teal` app.
#'
#' @inheritParams filter_spec
#' @param vars_choices (`character` or `delayed_data`) \cr
#'   the vector of dataset column names available to build dynamic filter
#'   \code{delayed_data} objects can be created via \code{\link{variable_choices}}.
#' @param vars_selected (`NULL` or named `character`) \cr
#'   the selected column name out from `choices`.
#' @param vars_label (`character`)\cr
#'   the title printed on the UI element generated on the basis of this \code{filter_spec}.
#' @param vars_fixed (`logical`)\cr
#'   if true allow to change the selected variables in the UI element; otherwise, do not allow.
#' @param vars_multiple (`logical`)\cr
#'   if true allow to select multiple variables in the UI elements; otherwise, do not allow.
#' @param fixed (`logical`)\cr
#'   if true allow to change the initially selected values of the variables; otherwise, do not allow.
#' @param dataname (`character`)\cr
#'   the name of the dataset this filter covers. Set during the initialization of the teal application.
#' @param initialized (`logical`)\cr
#'   indicates whether this filter was already initialized in the application.
#'   TRUE if this filter was already consumed by the server function; FALSE otherwise.
#'
#' @return `filter_spec` or `delayed_filter_spec` S3-class object.
#' @keywords internal
#'
#' @seealso filter_spec
#'
#' @examples
#' teal.transform:::filter_spec_internal(
#'   vars_choices = c("PARAMCD", "AVISIT"),
#'   vars_selected = "PARAMCD",
#'   vars_multiple = TRUE
#' )
#'
#' ADRS <- teal.transform::rADRS
#' teal.transform:::filter_spec_internal(
#'   vars_choices = variable_choices(ADRS),
#'   vars_selected = "PARAMCD",
#'   vars_multiple = TRUE
#' )
#'
#' teal.transform:::filter_spec_internal(
#'   vars_choices = variable_choices("ADRS"),
#'   vars_selected = "PARAMCD",
#'   vars_multiple = TRUE
#' )
filter_spec_internal <- function(vars_choices,
                                 vars_selected = NULL,
                                 vars_label = NULL,
                                 vars_fixed = FALSE,
                                 vars_multiple = TRUE,
                                 choices = NULL,
                                 selected = NULL,
                                 label = NULL,
                                 fixed = FALSE,
                                 multiple = TRUE,
                                 sep = attr(vars_choices, "sep"),
                                 drop_keys = FALSE,
                                 dataname = NULL,
                                 initialized = FALSE) {
  if (is.null(sep)) sep <- " - "
  checkmate::assert_string(vars_label, null.ok = TRUE)
  checkmate::assert_flag(vars_fixed)
  checkmate::assert_flag(vars_multiple)
  checkmate::assert_string(label, null.ok = TRUE)
  checkmate::assert_flag(fixed)
  checkmate::assert_flag(multiple)
  checkmate::assert_string(sep)
  checkmate::assert_flag(drop_keys)

  if (inherits(vars_choices, "delayed_data") ||
    inherits(vars_selected, "delayed_data") ||
    inherits(choices, "delayed_data") ||
    inherits(selected, "delayed_data")) {
    filter_spec_internal.delayed_data(
      vars_choices = vars_choices,
      vars_selected = vars_selected,
      vars_label = vars_label,
      vars_fixed = vars_fixed,
      vars_multiple = vars_multiple,
      choices = choices,
      selected = selected,
      label = label,
      multiple = multiple,
      fixed = fixed,
      sep = sep,
      drop_keys = drop_keys,
      dataname = dataname,
      initialized = initialized
    )
  } else {
    UseMethod("filter_spec_internal")
  }
}

#' @rdname filter_spec_internal
#' @export
filter_spec_internal.delayed_data <- function(vars_choices, # nolint
                                              vars_selected = NULL,
                                              vars_label = NULL,
                                              vars_fixed = FALSE,
                                              vars_multiple = TRUE,
                                              choices = NULL,
                                              selected = NULL,
                                              label = NULL,
                                              fixed = FALSE,
                                              multiple = TRUE,
                                              sep = attr(vars_choices, "sep"),
                                              drop_keys = FALSE,
                                              dataname = NULL,
                                              initialized = FALSE) {
  if (is.null(sep)) sep <- " - "
  checkmate::assert(
    checkmate::check_character(vars_choices, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(vars_choices, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(vars_choices, min.len = 1, any.missing = FALSE),
    checkmate::check_class(vars_choices, "delayed_data")
  )

  checkmate::assert(
    checkmate::check_null(vars_selected),
    checkmate::check_character(vars_selected, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(vars_selected, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(vars_selected, min.len = 1, any.missing = FALSE),
    checkmate::check_class(vars_selected, "delayed_data")
  )

  checkmate::assert(
    checkmate::check_null(choices),
    checkmate::check_character(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_class(choices, "delayed_data")
  )

  checkmate::assert(
    checkmate::check_null(selected),
    checkmate::check_character(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_class(selected, "delayed_data"),
    checkmate::check_class(selected, "all_choices")
  )

  out <- structure(
    list(
      vars_choices = vars_choices,
      vars_selected = vars_selected,
      vars_label = vars_label,
      vars_fixed = vars_fixed,
      vars_multiple = vars_multiple,
      choices = choices,
      selected = selected,
      label = label,
      multiple = multiple,
      fixed = fixed,
      sep = sep,
      drop_keys = drop_keys,
      dataname = dataname, # modified by data_extract_spec,
      initialized = initialized
    ),
    class = c(
      "delayed_filter_spec",
      "filter_spec",
      "delayed_data"
    )
  )
  return(out)
}

#' @rdname filter_spec_internal
#' @export
filter_spec_internal.default <- function(vars_choices,
                                         vars_selected = NULL,
                                         vars_label = NULL,
                                         vars_fixed = FALSE,
                                         vars_multiple = TRUE,
                                         choices = NULL,
                                         selected = NULL,
                                         label = NULL,
                                         fixed = FALSE,
                                         multiple = TRUE,
                                         sep = attr(vars_choices, "sep"),
                                         drop_keys = FALSE,
                                         dataname = NULL,
                                         initialized = FALSE) {
  if (is.null(sep)) sep <- " - "
  checkmate::assert(
    checkmate::check_character(vars_choices, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(vars_choices, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(vars_choices, min.len = 1, any.missing = FALSE)
  )
  stopifnot(all(!duplicated(vars_choices)))

  if (!is.null(vars_selected)) {
    stopifnot(vars_multiple || length(vars_selected) == 1)
    checkmate::assert(
      checkmate::check_character(vars_selected, min.len = 1, any.missing = FALSE),
      checkmate::check_numeric(vars_selected, min.len = 1, any.missing = FALSE),
      checkmate::check_logical(vars_selected, min.len = 1, any.missing = FALSE)
    )
    stopifnot(all(!duplicated(vars_selected)))
    stopifnot(all(vars_selected %in% vars_choices))
  }

  if (!is.null(choices)) {
    stopifnot(all(!duplicated(choices)))
    split_choices <- split_by_sep(choices, sep)
    stopifnot(all(vapply(split_choices, length, integer(1)) == length(vars_selected)))
  }

  if (!is.null(selected) && !inherits(selected, "all_choices")) {
    stopifnot(multiple || length(selected) == 1)
    checkmate::assert(
      checkmate::check_character(selected, min.len = 1, any.missing = FALSE),
      checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
      checkmate::check_logical(selected, min.len = 1, any.missing = FALSE)
    )
    stopifnot(all(!duplicated(selected)))
    stopifnot(all(selected %in% choices))
  }

  res <- list(
    vars_choices = vars_choices,
    vars_selected = vars_selected,
    vars_label = vars_label,
    vars_fixed = vars_fixed,
    vars_multiple = vars_multiple,
    choices = choices,
    selected = selected,
    label = label,
    multiple = multiple,
    fixed = fixed,
    sep = sep,
    drop_keys = drop_keys,
    dataname = dataname, # modified by data_extract_spec
    initialized = initialized
  )
  class(res) <- "filter_spec"

  return(res)
}

#' Get merge call from a list of selectors
#'
#' @description `r lifecycle::badge("stable")`
#' Returns list of calls depending on selector(s) and type of the merge
#' Order of merge is the same as in selectors passed to the function.
#' @inheritParams merge_datasets
#' @param join_keys (`JoinKeys`) nested list of keys used for joining
#' @param dplyr_call_data (`list`) simplified selectors with aggregated set of filters,
#'
#' @return (`list` with `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),
      { # nolint
        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
    )
  }
  return(anl_merge_calls)
}

#' Gets keys list from keys list
#'
#' @inheritParams get_merge_call
#' @return list of 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$get(selector_from$dataname, selector_to$dataname)
          )
        }
      )
    }
  )
}


#' Gets keys vector from keys list
#'
#' @param selector_from (`list`) `data_extract_srv`
#' @param selector_to (`list`) `data_extract_srv`
#' @param key_from (`character`) keys used in the first selector while joining
#'
#' @details This function covers up to now 4 cases
#' \itemize{
#'  \item{dataset without parent }{ Primary keys are returned}
#'  \item{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.
#'  }
#'  \item{target `dataname` is parent }{ foreign keys}
#'  \item{any other case }{foreign keys}
#' }
#'
#' @return (`character`)
#' @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 (`call`)
#' @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
#' @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 names `character` 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
#'
#' @description `r lifecycle::badge("stable")`
#' @inheritParams merge_datasets
#' @param columns_source \code{named list}\cr
#'  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
  )

  return(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`)\cr
#'   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)]

  return(
    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 which has 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
      return(column_source)
    }
  )
}

#' @title Formatting data extracts
#' @description Returns a human-readable string representation of an extracted `data_extract_spec` object.
#'
#' @details
#' This function formats the output of [`data_extract_srv`]. See the example for more information.
#'
#' @param data_extract `list` the list output of `data_extract_srv`
#' @return `character(1)` the string representation
#' @examples
#' simple_des <- data_extract_spec(
#'   dataname = "iris",
#'   filter = filter_spec(vars = "Petal.Length", choices = c("1.4", "1.5")),
#'   select = select_spec(choices = c("Petal.Length", "Species"))
#' )
#'
#' sample_filtered_data <- {
#'   teal.slice::init_filtered_data(
#'     list(iris = list(dataset = iris))
#'   )
#' }
#'
#' if (interactive()) {
#'   shiny::shinyApp(
#'     ui = shiny::fluidPage(
#'       data_extract_ui(
#'         id = "extract",
#'         label = "data extract ui",
#'         data_extract_spec = simple_des,
#'         is_single_dataset = TRUE
#'       ),
#'       shiny::verbatimTextOutput("formatted_extract")
#'     ),
#'     server = function(input, output, session) {
#'       extracted_input <- data_extract_srv(
#'         id = "extract",
#'         datasets = sample_filtered_data,
#'         data_extract_spec = simple_des
#'       )
#'       output$formatted_extract <- shiny::renderPrint({
#'         cat(format_data_extract(extracted_input()))
#'       })
#'     }
#'   )
#' }
#' @export
#'
format_data_extract <- function(data_extract) {
  if (is.null(data_extract)) {
    return(NULL)
  }

  checkmate::assert_list(data_extract)
  required_names <- c("select", "filters", "dataname")
  if (!checkmate::test_subset(required_names, choices = names(data_extract))) {
    stop(sprintf("data_extract must be a named list with names: %s", paste0(required_names, collapse = " ")))
  }

  out <- sprintf("<Data Extract for dataset: %s>", data_extract$dataname)
  out <- c(out, "Filters:")
  for (filter in data_extract$filters) {
    filtering_columns <- paste0(filter$columns, collapse = " ")
    selected_values <- paste0(filter$selected, collapse = " ")
    out <- c(out, sprintf("  Columns: %s Selected: %s", filtering_columns, selected_values))
  }

  out <- c(out, "Selected columns:")
  selected_columns <- paste0(data_extract$select, collapse = " ")
  out <- c(out, sprintf("  %s", selected_columns))

  paste0(out, collapse = "\n")
}

# also returns a list if only a single element
#' Split by separator
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (`character`) Character (single)
#' @param sep (`character`) Separator
#' @export
split_by_sep <- function(x, sep) {
  stopifnot(is.atomic(x))
  if (is.character(x)) {
    strsplit(x, sep, fixed = TRUE)
  } else {
    x
  }
}

#' Extract labels from choices basing on attributes and names
#'
#' @param choices (`list` or `vector`) select choices
#' @param values optional, choices subset for which labels should be extracted, `NULL` for all choices
#'
#' @return (`character`) vector with labels
#' @keywords internal
extract_choices_labels <- function(choices, values = NULL) {
  res <- if (inherits(choices, "choices_labeled")) {
    attr(choices, "raw_labels")
  } else if (!is.null(names(choices)) && !setequal(names(choices), unlist(unname(choices)))) {
    names(choices)
  } else {
    NULL
  }

  if (!is.null(values) && !is.null(res)) {
    stopifnot(all(values %in% choices))
    res <- res[vapply(values, function(val) which(val == choices), numeric(1))]
  }

  return(res)
}


#' Function to compose `validators` from `data_extract_multiple_srv`
#'
#' This function takes the output from `data_extract_multiple_srv` and
#' collates the `shinyvalidate::InputValidator`s returned into a single
#' `validator` and enables this
#'
#' @param iv (`shinyvalidate::InputValidator`) A `validator`.
#' @param selector_list (`reactive` named list of `reactives`).
#'   Typically this is the output from `data_extract_multiple_srv`.
#'   The `validators` in this list (specifically `selector_list()[[validator_names]]()iv`)
#'   will be added into `iv`.
#' @param validator_names (`character` or `NULL`). If `character` then only `validators`
#'   in the elements of `selector_list()` whose name is in this list will be added. If `NULL`
#'   all `validators` will be added
#' @return (`shinyvalidate::InputValidator`) enabled `iv` with appropriate `validators` added into it.
#' @export
#' @examples
#' library(shiny)
#' library(shinyvalidate)
#' library(shinyjs)
#' library(teal.widgets)
#'
#' iris_extract <- data_extract_spec(
#'   dataname = "iris",
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = variable_choices(iris, colnames(iris)),
#'     selected = "Sepal.Length",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#'
#' data_list <- list(iris = reactive(iris))
#'
#' app <- shinyApp(
#'   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_extract
#'         ),
#'         data_extract_ui(
#'           id = "y_var",
#'           label = "Please select a Y column",
#'           data_extract_spec = iris_extract
#'         ),
#'         data_extract_ui(
#'           id = "col_var",
#'           label = "Please select a color column",
#'           data_extract_spec = iris_extract
#'         )
#'       )
#'     )
#'   ),
#'   server = function(input, output, session) {
#'     exactly_2_validation <- function() {
#'       ~ if (length(.) != 2) "Exactly 2 'Y' column variables must be chosen"
#'     }
#'
#'
#'     selector_list <- data_extract_multiple_srv(
#'       list(x_var = iris_extract, y_var = iris_extract, col_var = iris_extract),
#'       datasets = data_list,
#'       select_validation_rule = list(
#'         x_var = sv_required("Please select an X column"),
#'         y_var = compose_rules(
#'           sv_required("Exactly 2 'Y' column variables must be chosen"),
#'           exactly_2_validation()
#'         )
#'       )
#'     )
#'     iv_r <- reactive({
#'       iv <- InputValidator$new()
#'       compose_and_enable_validators(
#'         iv,
#'         selector_list,
#'         # if validator_names = NULL then all validators are used
#'         # to turn on only "x_var" then set this argument to "x_var"
#'         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 {
#'         "Check that you have made a valid selection"
#'       }
#'     })
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
compose_and_enable_validators <- function(iv, selector_list, validator_names = NULL) {
  if (is.null(validator_names)) {
    validator_names <- names(selector_list())
  }
  valid_validator_names <- intersect(validator_names, names(selector_list()))

  for (validator_name in valid_validator_names) {
    single_des <- selector_list()[[validator_name]]()
    if (!is.null(single_des$iv)) {
      iv$add_validator(single_des$iv)
    }
  }
  iv$enable()
  iv
}

#' Check selector `dataname` element
#'
#' @param dataname selector element
#'
#' @return error or nothing
#'
#' @noRd
check_selector_dataname <- function(dataname) {
  checkmate::assert_string(dataname)
}

#' Check selector filters element
#'
#' @param filters selector element generated by `data_extract_srv`
#'
#' @return error or nothing
#'
#' @noRd
check_selector_filters <- function(filters) {
  check_selector_filter <- function(x) {
    is.list(x) &&
      all(c("columns", "selected") %in% names(x)) &&
      checkmate::test_character(x$columns, null.ok = TRUE, min.len = 1, any.missing = FALSE) &&
      (is.null(x$selected) ||
        all(vapply(x$selected, is.character, logical(1))) ||
        all(vapply(x$selected, is.numeric, logical(1)))
      )
  }
  stopifnot(is.null(filters) || all(vapply(filters, check_selector_filter, logical(1))))
}

#' Check selector select element
#'
#' @param select selector element generated by `data_extract_srv`
#'
#' @return error or nothing
#'
#' @noRd
check_selector_select <- function(select) {
  checkmate::assert_character(select)
}

#' Check selector keys element
#'
#' @param keys selector element generated by `data_extract_srv`
#'
#' @return error or nothing
#'
#' @noRd
check_selector_keys <- function(keys) {
  checkmate::assert_character(keys, min.len = 0L, any.missing = FALSE)
}

#' Check selector reshape element
#'
#' @param reshape selector element generated by `data_extract_srv`
#'
#' @return error or nothing
#'
#' @noRd
check_selector_reshape <- function(reshape) {
  checkmate::assert_flag(reshape)
}

#' Check selector internal_id element
#'
#' @param internal_id selector element generated by `data_extract_srv`
#'
#' @return error or nothing
#'
#' @noRd
check_selector_internal_id <- function(internal_id) {
  checkmate::assert_string(internal_id)
}

#' Check selector
#'
#' @param selector (`list`) of selector elements generated by `data_extract_srv`
#'
#' @return error or nothing
#'
#' @noRd
check_selector <- function(selector) {
  # An error from the checks below is transformed to a shiny::validate error
  # so shiny can display it in grey not in red in an application
  tryCatch(
    expr = {
      checkmate::assert_list(selector)
      checkmate::assert_names(
        names(selector),
        must.include = c("dataname", "filters", "select", "keys", "reshape", "internal_id")
      )
      check_selector_dataname(selector$dataname)
      check_selector_filters(selector$filters)
      check_selector_select(selector$select)
      check_selector_keys(selector$keys)
      check_selector_reshape(selector$reshape)
      check_selector_internal_id(selector$internal_id)
    },
    error = function(e) shiny::validate(e$message)
  )
}

#' Merge the datasets on the keys
#'
#' @description `r lifecycle::badge("experimental")`
#' It combines/merges multiple datasets with specified keys attribute.
#'
#'
#' @details Internally this function uses calls to allow reproducibility.
#'
#' @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.
#' @export
#'
#' @examples
#' \dontrun{
#' # 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()))
#' }
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, "JoinKeys")
  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
  )

  selector_datanames <- unique(vapply(merged_selector_list, `[[`, character(1), "dataname"))

  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.")
  return(res)
}

#' Merge selectors - select item if all of `dataname`, reshape, filters and keys items are identical
#'
#' @inheritParams merge_datasets
#'
#' @return error or nothing
#' @keywords internal
#'
#' @examples
#' selector_list <- list(
#'   # ADSL - SEX
#'   list(
#'     filters = NULL, select = "AGE", always_selected = NULL,
#'     reshape = FALSE, dataname = "ADSL",
#'     internal_id = "adsl_var", keys = c("STUDYID", "USUBJID")
#'   ),
#'
#'   # ADSL - AGE
#'   list(
#'     filters = NULL, select = "SEX", always_selected = NULL,
#'     reshape = FALSE, dataname = "ADSL",
#'     internal_id = "adsl_var2", keys = c("STUDYID", "USUBJID")
#'   ),
#'
#'   # ADLB - AVAL
#'   list(
#'     filters = NULL, select = "AVAL", always_selected = NULL,
#'     reshape = FALSE, dataname = "ADLB",
#'     internal_id = "adlb_var", keys = c(
#'       "STUDYID", "USUBJID",
#'       "PARAMCD", "AVISIT"
#'     )
#'   )
#' )
#' merged_selectors <- teal.transform:::merge_selectors(selector_list)
#' merged_selectors
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
    }
  }

  return(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
#' \code{dplyr} errors or unexpected results
#' @inheritParams merge_datasets
#' @return \code{NULL} if check is successful
#' @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 (`JoinKeys`) the provided join keys
#' @param merged_selector_list (`list`) the specification of datasets' slices to merge
#'
#' @return `TRUE` if the provided keys meet the requirements; the `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;
#' `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$get(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)
}

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

#' Returns a `shiny.tag` object with the UI for a `filter_spec` object
#'
#' @details Creates two `optionSelectInput` elements (one for column and one for values) based
#' on a definition of a [filter_spec()] object.
#'
#' @param filter (`filter_spec`) the object generated with [filter_spec()]
#' @param id (`character(1)`) the shiny `inputId` for the generated `shiny.tag`
#'
#' @return `shiny.tag` defining the `filter_spec`'s UI element
#' @keywords internal
#' @examples
#' teal.transform:::data_extract_filter_ui(filter = filter_spec(vars = "test_var"), id = "test_id")
data_extract_filter_ui <- function(filter, id = "filter") {
  checkmate::assert_class(filter, "filter_spec")
  checkmate::assert_string(id)

  ns <- NS(id)

  html_col <- teal.widgets::optionalSelectInput(
    inputId = ns("col"),
    label = filter$vars_label,
    choices = filter$vars_choices,
    selected = filter$vars_selected,
    multiple = filter$vars_multiple,
    fixed = filter$vars_fixed
  )

  html_vals <- teal.widgets::optionalSelectInput(
    inputId = ns("vals"),
    label = filter$label,
    choices = filter$choices,
    selected = filter$selected,
    multiple = filter$multiple,
    fixed = filter$fixed
  )

  div(
    class = "filter_spec",
    if (filter$vars_fixed) shinyjs::hidden(html_col) else html_col,
    html_vals
  )
}

#' Handles events emitted from the UI generated by `data_extract_filter_ui`.
#'
#' @note This shiny module server updates the values of the `vals`
#' [teal.widgets::optionalSelectInput()] widget. It's responsible
#' for setting the initial values and the subsequent updates to
#' the `vals` widget based on the input of the `col` widget.
#'
#' @param id (`character`) id string
#' @param datasets (`named list`) a list of reactive `data.frame` type objects.
#' @param filter (`filter_spec`) the filter generated by a call to [filter_spec()]
#' @keywords internal
data_extract_filter_srv <- function(id, datasets, filter) {
  checkmate::assert_list(datasets, types = "reactive", names = "named")
  moduleServer(
    id,
    function(input, output, session) {
      # We force the evaluation of filter, otherwise the observers are set up with the last element
      # of the list in data_extract_single_srv and not all of them (due to R lazy evaluation)
      force(filter)
      logger::log_trace(
        "data_extract_filter_srv initialized with: { filter$dataname } dataset."
      )

      observeEvent(input$col,
        handlerExpr = {
          if (!filter$initialized) {
            initial_inputs <- get_initial_filter_values(filter, datasets)
            choices <- initial_inputs$choices
            selected <- initial_inputs$selected
            filter$initialized <- TRUE
            filter <<- filter
          } else if (!rlang::is_empty(input$col)) {
            choices <- value_choices(
              datasets[[filter$dataname]](),
              input$col,
              `if`(isTRUE(input$col == attr(filter$choices, "var_choices")), attr(filter$choices, "var_label"), NULL)
            )

            selected <- if (!is.null(filter$selected)) {
              filter$selected
            } else if (filter$multiple) {
              choices
            } else {
              choices[1]
            }
          } else {
            choices <- character(0)
            selected <- character(0)
          }
          dn <- filter$dataname
          fc <- paste(input$col, collapse = ", ")
          logger::log_trace("data_extract_filter_srv@1 filter dataset: { dn }; filter var: { fc }.")
          # In order to force reactivity we run two updates: (i) set up dummy values (ii) set up appropriate values
          # It's due to a missing reactivity triggers if new selected value is identical with previously selected one.
          teal.widgets::updateOptionalSelectInput(
            session = session,
            inputId = "vals",
            choices = paste0(input$val, "$_<-_random_text_to_ensure_val_will_be_different_from_previous"),
            selected = paste0(input$val, "$_<-_random_text_to_ensure_val_will_be_different_from_previous")
          )

          teal.widgets::updateOptionalSelectInput(
            session = session,
            inputId = "vals",
            choices = choices,
            selected = selected
          )
        },
        ignoreInit = FALSE,
        ignoreNULL = FALSE
      )
    }
  )
}

#' Returns the initial values for the `vals` widget
#' of a `filter_spec` object.
#'
#' @inheritParams data_extract_filter_srv
#' @return `named list` with two slots `choices` and `selected`
#' @keywords internal
#'
#' @examples
#' filtered_data_list <- list(iris = shiny::reactive(utils::head(iris)))
#' filter <- filter_spec(vars = colnames(iris)[1])
#' filter$dataname <- "iris"
#' shiny::isolate(
#'   teal.transform:::get_initial_filter_values(filter = filter, datasets = filtered_data_list)
#' )
#'
get_initial_filter_values <- function(filter, datasets) {
  initial_values <- list()
  if (is.null(filter$vars_selected)) {
    initial_values$choices <- character(0)
    initial_values$selected <- character(0)
  } else if (is.null(filter$choices)) {
    initial_values$choices <- value_choices(
      datasets[[filter$dataname]](),
      as.character(filter$vars_selected)
    )
    initial_values$selected <- if (inherits(filter$selected, "all_choices")) {
      initial_values$choices
    } else {
      filter$selected
    }
  } else {
    initial_values$choices <- filter$choices
    initial_values$selected <- filter$selected
  }

  initial_values
}

#' Available datasets input
#'
#' @description `r lifecycle::badge("stable")`
#' Creates \link[shiny]{helpText} with the names of datasets
#' available for current module.
#' @param data_extracts list of data extracts for single variable
#' @export
datanames_input <- function(data_extracts) {
  datanames <- get_extract_datanames(data_extracts)
  helpText(
    paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
    tags$code(paste(datanames, collapse = ", "))
  )
}

#' Gets names of the datasets from a list of `data_extract_spec` objects
#'
#' @description `r lifecycle::badge("stable")`
#' Fetches `dataname` slot per \code{data_extract_spec} from a list of \code{data_extract_spec}
#' and returns the unique `dataname` set.
#'
#' @param data_extracts A single \code{data_extract_spec} object or a list (of lists) of \code{data_extract_spec}
#'
#' @export
get_extract_datanames <- function(data_extracts) {
  data_extracts <- if (inherits(data_extracts, "data_extract_spec")) {
    list(data_extracts)
  } else {
    data_extracts
  }
  checkmate::assert_list(data_extracts)

  data_extracts <- Filter(Negate(is.null), data_extracts)
  data_extracts <- Filter(Negate(is.logical), data_extracts)
  data_extracts <- Filter(Negate(is.choices_selected), data_extracts)

  stopifnot(length(data_extracts) > 0)
  stopifnot(
    checkmate::test_list(data_extracts, types = "data_extract_spec") ||
      all(
        vapply(data_extracts, function(x) checkmate::test_list(x, types = "data_extract_spec"), logical(1))
      )
  )

  datanames <- lapply(data_extracts, function(x) {
    if (inherits(x, "data_extract_spec")) {
      x[["dataname"]]
    } else if (checkmate::test_list(x, types = "data_extract_spec")) {
      lapply(x, `[[`, "dataname")
    }
  })

  unique(unlist(datanames))
}

#' Checks if the input `data_extract_spec` objects all come from the same dataset
#'
#' @description `r lifecycle::badge("stable")`
#' @param ... either \code{data_extract_spec} objects or lists of \code{data_extract_spec} objects that do not contain
#'   NULL
#' @return logical
#' @export
is_single_dataset <- function(...) {
  data_extract_spec <- list(...)
  dataset_names <- get_extract_datanames(data_extract_spec)
  return(length(dataset_names) == 1)
}

#' Data Extract input for teal modules
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The Data Extract input can be used to filter and select columns from a data
#' set. This function enables such an input in teal.
#' Please use the constructor function [data_extract_spec] to set it up.
#'
#' Note that no checks based on columns can be done because the data is only referred to by name.
#'
#' @export
#' @rdname data_extract_spec
#'
#' @section Module Development:
#' \describe{
#' `teal.transform` uses this object to construct a UI element in a module.
#' }
#'
#' @param dataname (`character`)\cr
#'  The name of the dataset to be extracted.
#' @param select (`NULL`, `select_spec`-S3 class or `delayed_select_spec`)\cr
#'  Columns to be selected from the input dataset
#'  mentioned in `dataname`. The setup can be created using [select_spec] function.
#' @param filter (`NULL` or `filter_spec` or its respective delayed version)\cr
#'  Setup of the filtering of key columns inside the dataset.
#'  This setup can be created using the [filter_spec] function.
#'  Please note that if both select and filter are set to NULL, then the result will be a filter spec UI with all
#'  variables as possible choices and a select spec with multiple set to `TRUE`.
#' @param reshape (`logical`)\cr
#'  whether reshape long to wide. Note that it will be used only in case of long dataset with multiple
#'  keys selected in filter part.
#'
#' @examples
#' 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"
#' )
#'
#' 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"
#'   )
#' )
#'
#' data_extract_spec(
#'   dataname = "ADSL",
#'   filter = NULL,
#'   select = select_spec(
#'     choices = c("AGE", "SEX", "USUBJID"),
#'     selected = c("SEX"),
#'     multiple = FALSE,
#'     fixed = FALSE
#'   )
#' )
#' data_extract_spec(
#'   dataname = "ADSL",
#'   filter = filter_spec(
#'     vars = variable_choices("ADSL", subset = c("AGE"))
#'   )
#' )
#'
#' dynamic_filter <- filter_spec(
#'   vars = choices_selected(variable_choices("ADSL"), "COUNTRY"),
#'   multiple = TRUE
#' )
#' data_extract_spec(
#'   dataname = "ADSL",
#'   filter = dynamic_filter
#' )
#'
#' @references [select_spec] [filter_spec]
data_extract_spec <- function(dataname, select = NULL, filter = NULL, reshape = FALSE) {
  checkmate::assert_string(dataname)
  stopifnot(
    is.null(select) ||
      (inherits(select, "select_spec") && length(select) >= 1)
  )
  checkmate::assert(
    checkmate::check_null(filter),
    checkmate::check_class(filter, "filter_spec"),
    checkmate::check_list(filter, "filter_spec")
  )
  checkmate::assert_flag(reshape)

  if (is.null(select) && is.null(filter)) {
    select <- select_spec(
      choices = variable_choices(dataname),
      multiple = TRUE
    )
    filter <- filter_spec(
      vars = choices_selected(variable_choices(dataname)),
      selected = all_choices()
    )
  }

  if (inherits(filter, "filter_spec")) filter <- list(filter)

  for (idx in seq_along(filter)) filter[[idx]]$dataname <- dataname

  if (inherits(select, "delayed_select_spec") ||
    any(vapply(filter, inherits, logical(1), "delayed_filter_spec"))) {
    structure(
      list(dataname = dataname, select = select, filter = filter, reshape = reshape),
      class = c("delayed_data_extract_spec", "delayed_data", "data_extract_spec")
    )
  } else {
    structure(
      list(dataname = dataname, select = select, filter = filter, reshape = reshape),
      class = "data_extract_spec"
    )
  }
}

# Contains modules to check the input provided to the `tm_*` functions is correct.
# In general, they are checking functions, in the sense that they call `stopifnot`
# if the conditions are not met.

#' Make sure that the extract spec has list form
#'
#' @md
#' @description `r lifecycle::badge("stable")`
#'
#' @param x `data_extract_spec` a single `data_extract_spec` or list of these
#' @param allow_null `logical` whether x can be `NULL`
#'
#' @return x as a list if it is not already
#'
#' @export
list_extract_spec <- function(x, allow_null = FALSE) {
  if (is.null(x)) {
    stopifnot(allow_null)
    return(NULL)
  }
  if (!checkmate::test_list(x, types = "data_extract_spec")) {
    x <- list(x)
  }
  stopifnot(checkmate::test_list(x, types = "data_extract_spec"))
  x
}

#' Checks that the extract_input specification does not allow multiple
#' selection
#'
#' @md
#' @description `r lifecycle::badge("stable")`
#'
#' @param extract_input `data_extract_spec` a list of `data_extract_spec` or NULL
#'
#' Stops if condition not met
#'
#' @export
check_no_multiple_selection <- function(extract_input) {
  # bug in is_class_list when NULL
  checkmate::assert_list(extract_input, types = "data_extract_spec", null.ok = TRUE)
  all(vapply(extract_input, function(elem) !isTRUE(elem$select$multiple), logical(1))) ||
    stop("extract_input variable should not allow multiple selection")
  invisible(NULL)
}

# Queue ====

#' @title R6 Class - A First-In-First-Out Abstract Data Type
#'
#' @description `r lifecycle::badge("experimental")`\cr
#' Abstract data type that stores and returns any number of elements.
#'
#' 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.
#'
#' @keywords internal
#'
Queue <- R6::R6Class( # nolint
  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 of length 1
    #'
    size = function() {
      length(self$get())
    },
    #' @description
    #' Prints this `Queue`.
    #'
    #' @param ... additional arguments to this method, ignored
    #'
    #' @return invisibly self
    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
)

#' Resolve delayed inputs by evaluating the code within the provided datasets
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (`delayed_data`, `list`) to resolve.
#' @param datasets (`FilteredData` or named `list`) to use as a reference to resolve `x`.
#' @param keys (named `list`) with primary keys for each dataset from `datasets`. `names(keys)`
#'   should match `names(datasets)`
#'
#' @return Resolved object.
#'
#' @export
#'
#' @examples
#' ADSL <- teal.transform::rADSL
#' shiny::isolate({
#'   ds <- teal.slice::init_filtered_data(
#'     list(ADSL = list(dataset = ADSL))
#'   )
#'
#'   # value_choices example
#'   v1 <- value_choices("ADSL", "SEX", "SEX")
#'   v1
#'   resolve_delayed(v1, ds)
#'
#'   # variable_choices example
#'   v2 <- variable_choices("ADSL", c("BMRKR1", "BMRKR2"))
#'   v2
#'   resolve_delayed(v2, ds)
#'
#'   # data_extract_spec example
#'   adsl_filter <- filter_spec(
#'     vars = variable_choices("ADSL", "SEX"),
#'     sep = "-",
#'     choices = value_choices("ADSL", "SEX", "SEX"),
#'     selected = "F",
#'     multiple = FALSE,
#'     label = "Choose endpoint and Censor"
#'   )
#'
#'   adsl_select <- select_spec(
#'     label = "Select variable:",
#'     choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
#'     selected = "BMRKR1",
#'     multiple = FALSE,
#'     fixed = FALSE
#'   )
#'
#'   adsl_de <- data_extract_spec(
#'     dataname = "ADSL",
#'     select = adsl_select,
#'     filter = adsl_filter
#'   )
#'
#'   resolve_delayed(adsl_filter, ds)
#'   resolve_delayed(adsl_select, ds)
#'   resolve_delayed(adsl_de, ds)
#'
#'   # nested list (arm_ref_comp)
#'   arm_ref_comp <- list(
#'     ARMCD = list(
#'       ref = variable_choices("ADSL"),
#'       comp = variable_choices("ADSL")
#'     )
#'   )
#'
#'   resolve_delayed(arm_ref_comp, ds)
#' })
resolve_delayed <- function(x, datasets, keys) {
  UseMethod("resolve_delayed", datasets)
}


#' @export
resolve_delayed.FilteredData <- function(x,
                                         datasets,
                                         keys = sapply(datasets$datanames(), datasets$get_keys, simplify = FALSE)) {
  datasets_list <- sapply(X = datasets$datanames(), simplify = FALSE, FUN = function(x) {
    reactive(datasets$get_data(dataname = x, filtered = TRUE))
  })
  resolve(x, datasets_list, keys)
}

#' @export
resolve_delayed.list <- function(x, datasets, keys = NULL) {
  checkmate::assert_list(datasets, type = c("reactive", "data.frame"), 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)
  )
  # convert to list of reactives
  datasets_list <- sapply(X = datasets, simplify = FALSE, FUN = function(x) {
    if (is.reactive(x)) x else reactive(x)
  })
  resolve(x, datasets_list, keys)
}

#' An S3 structure representing the selection of all
#' possible choices in a `filter_spec`, `select_spec` or `choices_selected` object.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @return `all_choices` object
#'
#' @examples
#' # Both structures are semantically identical
#' filter_spec(
#'   vars = c("selected_variable"),
#'   choices = c("value1", "value2"),
#'   selected = c("value1", "value2")
#' )
#'
#' filter_spec(
#'   vars = c("selected_variable"),
#'   choices = c("value1", "value2"),
#'   selected = all_choices()
#' )
#'
#' choices_selected(choices = letters, selected = letters)
#' choices_selected(choices = letters, selected = all_choices())
#' @export
all_choices <- function() {
  structure(list(), class = "all_choices")
}

#' Returns a `shiny.tag.list` object with the UI for a `select_spec` object
#'
#' @param select (`select_spec`) A definition of a select spec element.
#'  Setting [select_spec()] with `ordered = TRUE` makes this selector responsive to the variable
#'  selection order.
#' @param id (`character(1)`) The shiny `inputId` of the element
#' @return `shiny.tag.list` with the UI
#' @keywords internal
#' @examples
#' teal.transform:::data_extract_select_ui(
#'   select = select_spec(choices = "test_choice"),
#'   id = "test_id"
#' )
data_extract_select_ui <- function(select, id = "select") {
  checkmate::assert_class(select, "select_spec")
  checkmate::assert_string(id)

  ## select input
  res <- list(
    teal.widgets::optionalSelectInput(
      inputId = id,
      label = select$label,
      choices = select$choices,
      selected = select$selected,
      multiple = select$multiple,
      fixed = select$fixed
    )
  )

  if (!is.null(select$always_selected)) {
    res <- append(
      res,
      list(
        shinyjs::hidden(
          selectInput(
            inputId = paste0(id, "_additional"),
            label = "",
            choices = select$always_selected,
            selected = select$always_selected,
            multiple = length(select$always_selected) > 1
          )
        ),
        helpText(
          "Default Column(s)",
          tags$code(paste(select$always_selected, collapse = " "))
        )
      )
    )
  }

  do.call("tagList", res)
}

#' Data merge module
#'
#' @description `r lifecycle::badge("deprecated")`
#' @details This function was a convenient wrapper to combine `data_extract_multiple_srv()` and
#' `data_merge_srv()` when no additional processing is required.
#'
#' @inheritParams shiny::moduleServer
#' @param datasets (`FilteredData`)\cr
#'  object containing data, see [teal.slice::FilteredData] for more.
#' @param data_extract (named `list` of `data_extract_spec`)\cr
#' @param merge_function (`character(1)`)\cr
#'  A character string of a function that
#'  accepts the arguments `x`, `y` and `by` to perform the merging of datasets.
#' @param anl_name (`character(1)`)\cr
#'  Name of the analysis dataset.
#'
#' @return reactive expression with output from [data_merge_srv()].
#'
#' @seealso [data_merge_srv()]
#'
#' @export
data_merge_module <- function(datasets,
                              data_extract,
                              merge_function = "dplyr::full_join",
                              anl_name = "ANL",
                              id = "merge_id") {
  lifecycle::deprecate_stop("0.3.1", "data_merge_module()")
}


#' Data merge module server
#'
#' @description `r lifecycle::badge("deprecated")`
#' @details When additional processing of the `data_extract` list input was required, `data_merge_srv()` could be
#'   combined with `data_extract_multiple_srv()` or `data_extract_srv()` to influence the `selector_list` input.
#'
#' @inheritParams shiny::moduleServer
#' @param selector_list (`reactive`)\cr
#'   output from [data_extract_multiple_srv()] or a reactive named list of outputs from [data_extract_srv()].
#'   When using a reactive named list, the names must be identical to the shiny ids of the
#'   respective [data_extract_ui()].
#' @param datasets (`FilteredData`)\cr
#'  object containing data (see `teal.slice::FilteredData`).
#' @param merge_function (`character(1)` or `reactive`)\cr
#'  A character string of a function that accepts the arguments
#'  `x`, `y` and `by` to perform the merging of datasets.
#' @param anl_name (`character(1)`)\cr
#'  Name of the analysis dataset.
#'
#' @return reactive expression with output from [merge_datasets].
#'
#' @seealso [data_extract_srv()]
#'
#' @export
data_merge_srv <- function(id = "merge_id",
                           selector_list,
                           datasets,
                           merge_function = "dplyr::full_join",
                           anl_name = "ANL") {
  lifecycle::deprecate_stop("0.3.1", "data_merge_srv()")
}

1		#' Returns a reactive list with values read from the inputs of `data_extract_spec`
2		#'
3		#' @details Reads the UI inputs of a single `data_extract_spec` object in
4		#' a running `teal` application. Returns a reactive list of reactive values
5		#' read from the input. The returned list has keys corresponding to the UI
6		#' inputs: `select`, `filters`, `always_selected`, `reshape`.
7		#'
8		#' @inheritParams data_extract_single_srv
9		#' @return `shiny::reactive` the reactive list with reactive values read from the UI
10		#' @keywords internal
11		#'
12		data_extract_read_srv <- function(id, datasets, single_data_extract_spec, iv, select_validation_rule = NULL,
13		filter_validation_rule = NULL) {
14	22x	checkmate::assert_class(single_data_extract_spec, "data_extract_spec")
15	22x	checkmate::assert_list(datasets, types = "reactive", names = "named")
16	22x	moduleServer(
17	22x	id,
18	22x	function(input, output, session) {
19	22x	logger::log_trace(
20	22x	"data_extract_read_srv initialized with: { single_data_extract_spec$dataname } dataset."
21		)
22	22x	filter_idx <- seq_along(single_data_extract_spec$filter)
23	22x	extract_n_process_inputs <- function(idx) {
24	10x	x <- single_data_extract_spec$filter[[idx]]
25	10x	input_col <- input[[paste0("filter", idx, ns.sep, "col")]]
26	10x	input_vals <- input[[paste0("filter", idx, ns.sep, "vals")]]
27		# convert to numeric for class consistency because everything coming from input is character, e.g. "1"
28	10x	if (length(input_col) == 1L && is.numeric(datasets[[x$dataname]]()[[input_col]])) {
29	!	input_vals <- as.numeric(input_vals)
30		}
31	10x	for (col in input_col) {
32		# replace NA with NA_character_ for class consistency
33	!	if (any(vapply(input_vals, identical, logical(1), "NA")) &&
34	!	anyNA(datasets[[x$dataname]]()[col]) &&
35	!	!any(vapply(unique(datasets[[x$dataname]]()[col]), identical, logical(1), "NA"))) {
36	!	input_vals[vapply(input_vals, identical, logical(1), "NA")] <- NA_character_
37		}
38		}
39
40	10x	selected <- split_by_sep(input_vals, x$sep)
41
42	10x	dn <- single_data_extract_spec$dataname
43	10x	cols <- `if`(length(input_col) > 0, paste(input_col, collapse = ", "), "NULL")
44	10x	sel <- `if`(length(selected) > 0, paste(selected, collapse = ", "), "NULL")
45	10x	logger::log_trace("data_extract_read_srv@1 dataname: { dn }; filter vars: { cols }; filter values: { sel }")
46
47	10x	list(
48	10x	columns = input_col,
49	10x	selected = selected,
50	10x	multiple = x$multiple,
51	10x	drop_keys = x$drop_keys
52		)
53		}
54
55	22x	r_filter <- eventReactive(
56	22x	ignoreNULL = FALSE,
57	22x	eventExpr = {
58	19x	lapply(
59	19x	filter_idx,
60	19x	function(idx) {
61	10x	input[[paste0("filter", idx, ns.sep, "vals")]]
62		}
63		)
64		},
65	22x	valueExpr = {
66	19x	res <- if (length(single_data_extract_spec$filter) >= 1) {
67	10x	lapply(filter_idx, FUN = extract_n_process_inputs)
68		}
69	19x	res
70		}
71		)
72
73	22x	if (!is.null(select_validation_rule)) {
74	5x	iv$add_rule("select", select_validation_rule)
75		}
76
77	22x	if (!is.null(filter_validation_rule)) {
78	2x	for (idx in filter_idx) {
79	2x	iv$add_rule(
80	2x	paste0("filter", idx, ns.sep, "vals"),
81	2x	filter_validation_rule
82		)
83		}
84		}
85
86	22x	tracked_input <- Queue$new()
87	22x	r_select <- eventReactive(
88	22x	ignoreNULL = FALSE,
89	22x	eventExpr = {
90	29x	input$select
91		# Note that r_select reactivity is triggered by filter vals and not filter col.
92		# This is intended since filter col updates filter vals which is then updating both r_filter and r_select.
93		# If it depends on filter col then there will be two reactivity cycles:
94		# (1) filter-col -> r_select -> read -> ... (2) filter-col -> filter-val -> r_filter -> read -> ...
95	29x	lapply(
96	29x	filter_idx,
97	29x	function(idx) {
98	12x	input[[paste0("filter", idx, shiny::ns.sep, "vals")]]
99		}
100		)
101		},
102	22x	valueExpr = {
103	29x	if (isTRUE(single_data_extract_spec$select$ordered)) {
104	3x	shinyjs::runjs(
105	3x	sprintf(
106	3x	'$("#%s").parent().find("span.caret").removeClass("caret").addClass("fas fa-exchange-alt")',
107	3x	session$ns("select")
108		)
109		)
110	3x	tracked_input$remove(setdiff(tracked_input$get(), input$select))
111	3x	tracked_input$push(setdiff(input$select, tracked_input$get()))
112	3x	res <- tracked_input$get()
113	3x	res <- if (is.null(res)) character(0) else res
114		} else {
115	26x	res <- if (is.null(input$select)) {
116	15x	if (is.null(single_data_extract_spec$select)) {
117	4x	as.character(unlist(lapply(
118	4x	filter_idx,
119	4x	function(idx) {
120	4x	input[[paste0("filter", idx, ns.sep, "col")]]
121		}
122		)))
123		} else {
124	11x	character(0)
125		}
126		} else {
127	11x	input$select
128		}
129
130	26x	if (!is.null(input$select_additional)) {
131	!	res <- append(res, input$select_additional)
132		}
133	26x	res
134		}
135
136	29x	dn <- single_data_extract_spec$dataname
137	29x	sel <- `if`(length(res) > 0, paste(res, collapse = ", "), "NULL")
138	29x	logger::log_trace("data_extract_read_srv@2 dataname: { dn }; select: { sel }.")
139
140	29x	res
141		}
142		)
143
144	22x	r_reshape <- reactive({
145	15x	res <- if (is.null(input$reshape)) {
146	15x	FALSE
147		} else {
148	!	input$reshape
149		}
150
151	15x	dn <- single_data_extract_spec$dataname
152	15x	resh <- paste(res, collapse = ", ")
153	15x	logger::log_trace("data_extract_read_srv@3 dataname: { dn }; reshape: { resh }.")
154
155	15x	res
156		})
157
158	22x	reactive({
159	29x	list(
160	29x	filters = r_filter(),
161	29x	select = r_select(),
162	29x	always_selected = single_data_extract_spec$select$always_selected,
163	29x	reshape = r_reshape(),
164	29x	iv = iv
165		)
166		})
167		}
168		)
169		}

1		#' Returns a `shiny.tag` with the UI elements for a `data_extract_spec`
2		#'
3		#' @details Creates a `shiny.tag` element defining the UI elements corresponding
4		#' a single `data_extract_spec` object.
5		#'
6		#' @param id (`character(1)`) the id of the module
7		#' @param single_data_extract_spec (`data_extract_spec`) the [data_extract_spec()] object to handle.
8		#'
9		#' @return `shiny.tag` the HTML element defining the UI
10		#' @keywords internal
11		#'
12		#' @examples
13		#' teal.transform:::data_extract_single_ui(id = "test", data_extract_spec("extract"))
14		data_extract_single_ui <- function(id = NULL, single_data_extract_spec) {
15	4x	stopifnot(inherits(single_data_extract_spec, "data_extract_spec"))
16	4x	ns <- NS(id)
17
18		## filter input
19	4x	extract_spec_filter <- single_data_extract_spec$filter
20	4x	filter_display <- do.call(
21	4x	div,
22	4x	lapply(
23	4x	seq_along(extract_spec_filter),
24	4x	function(idx) {
25	6x	x <- extract_spec_filter[[idx]]
26	6x	if (inherits(x, "filter_spec")) {
27	6x	data_extract_filter_ui(filter = x, id = ns(paste0("filter", idx)))
28		} else {
29	!	stop("Unsupported object class")
30		}
31		}
32		)
33		)
34
35		## select input
36	4x	extract_spec_select <- single_data_extract_spec$select
37	4x	if (!is.null(extract_spec_select$fixed)) {
38	4x	attr(extract_spec_select$fixed, which = "dataname") <- single_data_extract_spec$dataname
39		}
40
41	4x	select_display <- if (is.null(extract_spec_select)) {
42	!	NULL
43		} else {
44	4x	data_extract_select_ui(extract_spec_select, id = ns("select"))
45		}
46
47		## reshape input
48	4x	extract_spec_reshape <- single_data_extract_spec$reshape
49	4x	reshape_display <- checkboxInput(
50	4x	inputId = ns("reshape"),
51	4x	label = "Reshape long to wide format",
52	4x	value = extract_spec_reshape
53		)
54		# always disable reshape button and hide if it is not pre-configured
55	4x	reshape_display <- shinyjs::disabled(reshape_display)
56	4x	if (!extract_spec_reshape) reshape_display <- shinyjs::hidden(reshape_display)
57
58		## all combined
59	4x	div(filter_display, select_display, reshape_display)
60		}
61
62		#' The server function for a single `data_extract_spec` object
63		#'
64		#' @details The Shiny server function for handling a single
65		#' [data_extract_spec] object.
66		#'
67		#' @inheritParams data_extract_filter_srv
68		#' @inheritParams data_extract_single_ui
69		#'
70		#' @return `NULL`
71		#' @keywords internal
72		data_extract_single_srv <- function(id, datasets, single_data_extract_spec) {
73	22x	moduleServer(
74	22x	id,
75	22x	function(input, output, session) {
76	22x	logger::log_trace(
77	22x	"data_extract_single_srv initialized with dataset: { single_data_extract_spec$dataname }."
78		)
79	22x	for (idx in seq_along(single_data_extract_spec$filter)) {
80	8x	x <- single_data_extract_spec$filter[[idx]]
81	8x	if (inherits(x, "filter_spec")) {
82	8x	data_extract_filter_srv(
83	8x	id = paste0("filter", idx),
84	8x	datasets = datasets,
85	8x	filter = x
86		)
87		}
88	8x	NULL
89		}
90		}
91		)
92		}

1		#' Column selection input specification
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' \code{select_spec} is used inside teal to create a \code{\link[shiny]{selectInput}}
5		#' that will select columns from a dataset.
6		#'
7		#' @param choices (\code{character}) or (\code{delayed_data}) object.
8		#' Named character vector to define the choices
9		#' of a shiny \code{\link[shiny]{selectInput}}. These have to be columns in the
10		#' dataset defined in the \code{\link{data_extract_spec}} where this is called.
11		#' \code{delayed_data} objects can be created via \code{\link{variable_choices}} or \code{\link{value_choices}}.
12		#'
13		#' @param selected optional (\code{character} or \code{NULL} or \code{all_choices} or \code{delayed_data} object).
14		#' Named character vector to define the selected values of a shiny \code{\link[shiny]{selectInput}}.
15		#' Passing an `all_choices()` object indicates selecting all possible choices.
16		#' Defaults to the first value of \code{choices} or \code{NULL} for delayed data loading.
17		#'
18		#' @param multiple (\code{logical}) Whether multiple values shall be allowed in the
19		#' shiny \code{\link[shiny]{selectInput}}.
20		#'
21		#' @param fixed optional (\code{logical}). \code{\link{data_extract_spec}} specific feature to
22		#' hide the choices selected in case they are not needed. Setting fixed to \code{TRUE}
23		#' will not allow the user to select columns. It will then lead to a selection of
24		#' columns in the dataset that is defined by the developer of the app.
25		#'
26		#' @param always_selected (\code{character}) Additional column names from the data set that should
27		#' always be selected
28		#'
29		#' @param ordered (`logical(1)`) Flags whether selection order should be tracked.
30		#'
31		#' @param label optional (\code{character}). Define a label on top of this specific
32		#' shiny \code{\link[shiny]{selectInput}}. The default value is \code{"Select"}.
33		#'
34		#' @return A \code{select_spec}-S3 class object or \code{delayed_select_spec}-S3-class object.
35		#' It contains all input values.
36		#' If \code{select_spec}, then the function double checks the \code{choices} and \code{selected} inputs.
37		#'
38		#'
39		#' @rdname select_spec
40		#'
41		#' @export
42		#'
43		#' @examples
44		#' # Selection with just one column allowed
45		#' select_spec(
46		#' choices = c("AVAL", "BMRKR1", "AGE"),
47		#' selected = c("AVAL"),
48		#' multiple = FALSE,
49		#' fixed = FALSE,
50		#' label = "Column"
51		#' )
52		#'
53		#' # Selection with just multiple columns allowed
54		#' select_spec(
55		#' choices = c("AVAL", "BMRKR1", "AGE"),
56		#' selected = c("AVAL", "BMRKR1"),
57		#' multiple = TRUE,
58		#' fixed = FALSE,
59		#' label = "Columns"
60		#' )
61		#'
62		#' # Selection without user access
63		#' select_spec(
64		#' choices = c("AVAL", "BMRKR1"),
65		#' selected = c("AVAL", "BMRKR1"),
66		#' multiple = TRUE,
67		#' fixed = TRUE,
68		#' label = "Columns"
69		#' )
70		#'
71		#' # Delayed version
72		#' select_spec(
73		#' label = "Select variable:",
74		#' choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
75		#' selected = "BMRKR1",
76		#' multiple = FALSE,
77		#' fixed = FALSE
78		#' )
79		#'
80		#' # all_choices passed to selected
81		#' select_spec(
82		#' label = "Select variable:",
83		#' choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
84		#' selected = all_choices()
85		#' )
86		#'
87		#' # Both below objects are semantically the same
88		#' select_spec(choices = variable_choices("ADSL"), selected = variable_choices("ADSL"))
89		#' select_spec(choices = variable_choices("ADSL"), selected = all_choices())
90		select_spec <- function(choices,
91		selected = `if`(inherits(choices, "delayed_data"), NULL, choices[1]),
92		multiple = length(selected) > 1 \|\| inherits(selected, "all_choices"),
93		fixed = FALSE,
94		always_selected = NULL,
95		ordered = FALSE,
96		label = "Select") {
97	142x	checkmate::assert_flag(multiple)
98	140x	checkmate::assert_flag(fixed)
99	139x	checkmate::assert_character(always_selected, min.len = 1, null.ok = TRUE, any.missing = FALSE)
100	139x	checkmate::assert_flag(ordered)
101	139x	checkmate::assert_string(label, null.ok = TRUE)
102	138x	stopifnot(multiple \|\| !inherits(selected, "all_choices"))
103	!	if (fixed) stopifnot(is.null(always_selected))
104
105	3x	if (inherits(selected, "all_choices")) selected <- choices
106	138x	if (inherits(choices, "delayed_data") \|\| inherits(selected, "delayed_data")) {
107	39x	select_spec.delayed_data(choices, selected, multiple, fixed, always_selected, ordered, label)
108		} else {
109	99x	select_spec.default(choices, selected, multiple, fixed, always_selected, ordered, label)
110		}
111		}
112
113		#' @rdname select_spec
114		#' @export
115		select_spec.delayed_data <- function(choices, # nolint
116		selected = NULL,
117		multiple = length(selected) > 1,
118		fixed = FALSE,
119		always_selected = NULL,
120		ordered = FALSE,
121		label = NULL) {
122	39x	stopifnot(is.null(selected) \|\| is.atomic(selected) \|\| inherits(selected, "delayed_data"))
123	39x	stopifnot(is.null(choices) \|\| is.atomic(choices) \|\| inherits(choices, "delayed_data"))
124
125	39x	structure(
126	39x	list(
127	39x	choices = choices,
128	39x	selected = selected,
129	39x	multiple = multiple,
130	39x	fixed = fixed,
131	39x	always_selected = always_selected,
132	39x	ordered = ordered,
133	39x	label = label
134		),
135	39x	class = c("delayed_select_spec", "delayed_data", "select_spec")
136		)
137		}
138
139		#' @rdname select_spec
140		#' @export
141		select_spec.default <- function(choices, # nolint
142		selected = choices[1],
143		multiple = length(selected) > 1,
144		fixed = FALSE,
145		always_selected = NULL,
146		ordered = FALSE,
147		label = NULL) {
148	99x	stopifnot(is.null(choices) \|\| is.atomic(choices))
149	98x	stopifnot(is.null(selected) \|\| is.atomic(selected))
150
151		# if names is NULL, shiny will put strange labels (with quotes etc.) in the selectInputs, so we set it to the values
152	97x	if (is.null(names(choices))) {
153	24x	names(choices) <- as.character(choices)
154		}
155
156		# Deal with selected
157	97x	if (length(selected) > 0) {
158	77x	stopifnot(is.atomic(selected))
159	77x	stopifnot(all(selected %in% choices))
160	77x	stopifnot(multiple \|\| length(selected) == 1)
161	76x	if (is.null(names(selected))) {
162	41x	names(selected) <- as.character(selected)
163		}
164		}
165
166	96x	if (length(intersect(choices, always_selected)) > 0) {
167	!	warning("You cannot allow the user to select 'always_selected' columns.
168	!	'choices' and 'always_selected' will be intersected")
169	!	test_c <- choices[which(!choices %in% always_selected)]
170	!	if (length(test_c) > 0) {
171	!	class(test_c) <- c("choices_labeled", "character")
172	!	choices <- test_c
173		} else {
174	!	choices <- NULL
175		}
176		}
177
178	96x	res <- list(
179	96x	choices = choices, selected = selected, multiple = multiple, fixed = fixed,
180	96x	always_selected = always_selected, ordered = ordered, label = label
181		)
182	96x	class(res) <- "select_spec"
183
184	96x	return(res)
185		}

1		# also returns a list if only a single element
2		#' Split by separator
3		#'
4		#' @description `r lifecycle::badge("stable")`
5		#'
6		#' @param x (`character`) Character (single)
7		#' @param sep (`character`) Separator
8		#' @export
9		split_by_sep <- function(x, sep) {
10	103x	stopifnot(is.atomic(x))
11	103x	if (is.character(x)) {
12	96x	strsplit(x, sep, fixed = TRUE)
13		} else {
14	7x	x
15		}
16		}
17
18		#' Extract labels from choices basing on attributes and names
19		#'
20		#' @param choices (`list` or `vector`) select choices
21		#' @param values optional, choices subset for which labels should be extracted, `NULL` for all choices
22		#'
23		#' @return (`character`) vector with labels
24		#' @keywords internal
25		extract_choices_labels <- function(choices, values = NULL) {
26	!	res <- if (inherits(choices, "choices_labeled")) {
27	!	attr(choices, "raw_labels")
28	!	} else if (!is.null(names(choices)) && !setequal(names(choices), unlist(unname(choices)))) {
29	!	names(choices)
30		} else {
31	!	NULL
32		}
33
34	!	if (!is.null(values) && !is.null(res)) {
35	!	stopifnot(all(values %in% choices))
36	!	res <- res[vapply(values, function(val) which(val == choices), numeric(1))]
37		}
38
39	!	return(res)
40		}
41
42
43		#' Function to compose `validators` from `data_extract_multiple_srv`
44		#'
45		#' This function takes the output from `data_extract_multiple_srv` and
46		#' collates the `shinyvalidate::InputValidator`s returned into a single
47		#' `validator` and enables this
48		#'
49		#' @param iv (`shinyvalidate::InputValidator`) A `validator`.
50		#' @param selector_list (`reactive` named list of `reactives`).
51		#' Typically this is the output from `data_extract_multiple_srv`.
52		#' The `validators` in this list (specifically `selector_list()[[validator_names]]()iv`)
53		#' will be added into `iv`.
54		#' @param validator_names (`character` or `NULL`). If `character` then only `validators`
55		#' in the elements of `selector_list()` whose name is in this list will be added. If `NULL`
56		#' all `validators` will be added
57		#' @return (`shinyvalidate::InputValidator`) enabled `iv` with appropriate `validators` added into it.
58		#' @export
59		#' @examples
60		#' library(shiny)
61		#' library(shinyvalidate)
62		#' library(shinyjs)
63		#' library(teal.widgets)
64		#'
65		#' iris_extract <- data_extract_spec(
66		#' dataname = "iris",
67		#' select = select_spec(
68		#' label = "Select variable:",
69		#' choices = variable_choices(iris, colnames(iris)),
70		#' selected = "Sepal.Length",
71		#' multiple = TRUE,
72		#' fixed = FALSE
73		#' )
74		#' )
75		#'
76		#' data_list <- list(iris = reactive(iris))
77		#'
78		#' app <- shinyApp(
79		#' ui = fluidPage(
80		#' useShinyjs(),
81		#' standard_layout(
82		#' output = verbatimTextOutput("out1"),
83		#' encoding = tagList(
84		#' data_extract_ui(
85		#' id = "x_var",
86		#' label = "Please select an X column",
87		#' data_extract_spec = iris_extract
88		#' ),
89		#' data_extract_ui(
90		#' id = "y_var",
91		#' label = "Please select a Y column",
92		#' data_extract_spec = iris_extract
93		#' ),
94		#' data_extract_ui(
95		#' id = "col_var",
96		#' label = "Please select a color column",
97		#' data_extract_spec = iris_extract
98		#' )
99		#' )
100		#' )
101		#' ),
102		#' server = function(input, output, session) {
103		#' exactly_2_validation <- function() {
104		#' ~ if (length(.) != 2) "Exactly 2 'Y' column variables must be chosen"
105		#' }
106		#'
107		#'
108		#' selector_list <- data_extract_multiple_srv(
109		#' list(x_var = iris_extract, y_var = iris_extract, col_var = iris_extract),
110		#' datasets = data_list,
111		#' select_validation_rule = list(
112		#' x_var = sv_required("Please select an X column"),
113		#' y_var = compose_rules(
114		#' sv_required("Exactly 2 'Y' column variables must be chosen"),
115		#' exactly_2_validation()
116		#' )
117		#' )
118		#' )
119		#' iv_r <- reactive({
120		#' iv <- InputValidator$new()
121		#' compose_and_enable_validators(
122		#' iv,
123		#' selector_list,
124		#' # if validator_names = NULL then all validators are used
125		#' # to turn on only "x_var" then set this argument to "x_var"
126		#' validator_names = NULL
127		#' )
128		#' })
129		#'
130		#' output$out1 <- renderPrint({
131		#' if (iv_r()$is_valid()) {
132		#' ans <- lapply(selector_list(), function(x) {
133		#' cat(format_data_extract(x()), "\n\n")
134		#' })
135		#' } else {
136		#' "Check that you have made a valid selection"
137		#' }
138		#' })
139		#' }
140		#' )
141		#' if (interactive()) {
142		#' runApp(app)
143		#' }
144		compose_and_enable_validators <- function(iv, selector_list, validator_names = NULL) {
145	7x	if (is.null(validator_names)) {
146	7x	validator_names <- names(selector_list())
147		}
148	7x	valid_validator_names <- intersect(validator_names, names(selector_list()))
149
150	7x	for (validator_name in valid_validator_names) {
151	14x	single_des <- selector_list()[[validator_name]]()
152	14x	if (!is.null(single_des$iv)) {
153	14x	iv$add_validator(single_des$iv)
154		}
155		}
156	7x	iv$enable()
157	7x	iv
158		}

1		#' Check selector `dataname` element
2		#'
3		#' @param dataname selector element
4		#'
5		#' @return error or nothing
6		#'
7		#' @noRd
8		check_selector_dataname <- function(dataname) {
9	2774x	checkmate::assert_string(dataname)
10		}
11
12		#' Check selector filters element
13		#'
14		#' @param filters selector element generated by `data_extract_srv`
15		#'
16		#' @return error or nothing
17		#'
18		#' @noRd
19		check_selector_filters <- function(filters) {
20	2771x	check_selector_filter <- function(x) {
21	3080x	is.list(x) &&
22	3080x	all(c("columns", "selected") %in% names(x)) &&
23	3080x	checkmate::test_character(x$columns, null.ok = TRUE, min.len = 1, any.missing = FALSE) &&
24	3080x	(is.null(x$selected) \|\|
25	3080x	all(vapply(x$selected, is.character, logical(1))) \|\|
26	3080x	all(vapply(x$selected, is.numeric, logical(1)))
27		)
28		}
29	2771x	stopifnot(is.null(filters) \|\| all(vapply(filters, check_selector_filter, logical(1))))
30		}
31
32		#' Check selector select element
33		#'
34		#' @param select selector element generated by `data_extract_srv`
35		#'
36		#' @return error or nothing
37		#'
38		#' @noRd
39		check_selector_select <- function(select) {
40	2771x	checkmate::assert_character(select)
41		}
42
43		#' Check selector keys element
44		#'
45		#' @param keys selector element generated by `data_extract_srv`
46		#'
47		#' @return error or nothing
48		#'
49		#' @noRd
50		check_selector_keys <- function(keys) {
51	2771x	checkmate::assert_character(keys, min.len = 0L, any.missing = FALSE)
52		}
53
54		#' Check selector reshape element
55		#'
56		#' @param reshape selector element generated by `data_extract_srv`
57		#'
58		#' @return error or nothing
59		#'
60		#' @noRd
61		check_selector_reshape <- function(reshape) {
62	2771x	checkmate::assert_flag(reshape)
63		}
64
65		#' Check selector internal_id element
66		#'
67		#' @param internal_id selector element generated by `data_extract_srv`
68		#'
69		#' @return error or nothing
70		#'
71		#' @noRd
72		check_selector_internal_id <- function(internal_id) {
73	2771x	checkmate::assert_string(internal_id)
74		}
75
76		#' Check selector
77		#'
78		#' @param selector (`list`) of selector elements generated by `data_extract_srv`
79		#'
80		#' @return error or nothing
81		#'
82		#' @noRd
83		check_selector <- function(selector) {
84		# An error from the checks below is transformed to a shiny::validate error
85		# so shiny can display it in grey not in red in an application
86	2771x	tryCatch(
87	2771x	expr = {
88	2771x	checkmate::assert_list(selector)
89	2771x	checkmate::assert_names(
90	2771x	names(selector),
91	2771x	must.include = c("dataname", "filters", "select", "keys", "reshape", "internal_id")
92		)
93	2771x	check_selector_dataname(selector$dataname)
94	2771x	check_selector_filters(selector$filters)
95	2771x	check_selector_select(selector$select)
96	2771x	check_selector_keys(selector$keys)
97	2771x	check_selector_reshape(selector$reshape)
98	2771x	check_selector_internal_id(selector$internal_id)
99		},
100	2771x	error = function(e) shiny::validate(e$message)
101		)
102		}

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

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

1		#' Merge expression module
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#' @details This function is a convenient wrapper to combine `data_extract_multiple_srv()` and
5		#' `merge_expression_srv()` when no additional processing is required.
6		#' Compare the example below with that found in [merge_expression_srv()].
7		#'
8		#' @inheritParams shiny::moduleServer
9		#' @param datasets (named `list` of `reactive` or non-`reactive` `data.frame`)\cr
10		#' object containing data as a list of `data.frame`. When passing a list of non-reactive `data.frame` objects, they are
11		#' converted to reactive `data.frame` objects internally.
12		#' @param join_keys (`JoinKeys`)\cr
13		#' of variables used as join keys for each of the datasets in `datasets`.
14		#' This will be used to extract the `keys` of every dataset.
15		#' @param data_extract (named `list` of `data_extract_spec`)\cr
16		#' @param merge_function (`character(1)`)\cr
17		#' A character string of a function that
18		#' accepts the arguments `x`, `y` and `by` to perform the merging of datasets.
19		#' @param anl_name (`character(1)`)\cr
20		#' Name of the analysis dataset.
21		#'
22		#' @return reactive expression with output from [merge_expression_srv()].
23		#'
24		#' @seealso [merge_expression_srv()]
25		#'
26		#' @examples
27		#' library(shiny)
28		#' ADSL <- data.frame(
29		#' STUDYID = "A",
30		#' USUBJID = LETTERS[1:10],
31		#' SEX = rep(c("F", "M"), 5),
32		#' AGE = rpois(10, 30),
33		#' BMRKR1 = rlnorm(10)
34		#' )
35		#' ADLB <- expand.grid(
36		#' STUDYID = "A",
37		#' USUBJID = LETTERS[1:10],
38		#' PARAMCD = c("ALT", "CRP", "IGA"),
39		#' AVISIT = c("SCREENING", "BASELINE", "WEEK 1 DAY 8", "WEEK 2 DAY 15")
40		#' )
41		#' ADLB$AVAL <- rlnorm(120)
42		#' ADLB$CHG <- rnorm(120)
43		#'
44		#' data_list <- list(
45		#' ADSL = ADSL,
46		#' ADLB = ADLB
47		#' )
48		#'
49		#' join_keys <- teal.data::join_keys(
50		#' teal.data::join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")),
51		#' teal.data::join_key("ADSL", "ADLB", c("STUDYID", "USUBJID")),
52		#' teal.data::join_key("ADLB", "ADLB", c("STUDYID", "USUBJID", "PARAMCD", "AVISIT"))
53		#' )
54		#'
55		#'
56		#' adsl_extract <- data_extract_spec(
57		#' dataname = "ADSL",
58		#' select = select_spec(
59		#' label = "Select variable:",
60		#' choices = c("AGE", "BMRKR1"),
61		#' selected = "AGE",
62		#' multiple = TRUE,
63		#' fixed = FALSE
64		#' )
65		#' )
66		#' adlb_extract <- data_extract_spec(
67		#' dataname = "ADLB",
68		#' filter = filter_spec(vars = "PARAMCD", choices = c("ALT", "CRP", "IGA"), selected = "ALT"),
69		#' select = select_spec(
70		#' label = "Select variable:",
71		#' choices = c("AVAL", "CHG"),
72		#' selected = "AVAL",
73		#' multiple = TRUE,
74		#' fixed = FALSE
75		#' )
76		#' )
77		#' app <- shinyApp(
78		#' ui = fluidPage(
79		#' teal.widgets::standard_layout(
80		#' output = div(
81		#' verbatimTextOutput("expr"),
82		#' dataTableOutput("data")
83		#' ),
84		#' encoding = tagList(
85		#' data_extract_ui("adsl_var", label = "ADSL selection", adsl_extract),
86		#' data_extract_ui("adlb_var", label = "ADLB selection", adlb_extract)
87		#' )
88		#' )
89		#' ),
90		#' server = function(input, output, session) {
91		#' data_q <- teal.code::new_qenv()
92		#'
93		#' data_q <- teal.code::eval_code(
94		#' data_q,
95		#' "ADSL <- data.frame(
96		#' STUDYID = 'A',
97		#' USUBJID = LETTERS[1:10],
98		#' SEX = rep(c('F', 'M'), 5),
99		#' AGE = rpois(10, 30),
100		#' BMRKR1 = rlnorm(10)
101		#' )"
102		#' )
103		#'
104		#' data_q <- teal.code::eval_code(
105		#' data_q,
106		#' "ADLB <- expand.grid(
107		#' STUDYID = 'A',
108		#' USUBJID = LETTERS[1:10],
109		#' PARAMCD = c('ALT', 'CRP', 'IGA'),
110		#' AVISIT = c('SCREENING', 'BASELINE', 'WEEK 1 DAY 8', 'WEEK 2 DAY 15'),
111		#' AVAL = rlnorm(120),
112		#' CHG = rlnorm(120)
113		#' )"
114		#' )
115		#'
116		#' merged_data <- merge_expression_module(
117		#' data_extract = list(adsl_var = adsl_extract, adlb_var = adlb_extract),
118		#' datasets = data_list,
119		#' join_keys = join_keys,
120		#' merge_function = "dplyr::left_join"
121		#' )
122		#'
123		#' code_merge <- reactive({
124		#' for (exp in merged_data()$expr) data_q <- teal.code::eval_code(data_q, exp)
125		#' data_q
126		#' })
127		#'
128		#' output$expr <- renderText(paste(merged_data()$expr, collapse = "\n"))
129		#' output$data <- renderDataTable(code_merge()[["ANL"]])
130		#' }
131		#' )
132		#' \dontrun{
133		#' runApp(app)
134		#' }
135		#' @export
136		merge_expression_module <- function(datasets,
137		join_keys = NULL,
138		data_extract,
139		merge_function = "dplyr::full_join",
140		anl_name = "ANL",
141		id = "merge_id") {
142	5x	logger::log_trace("merge_expression_module called with: { paste(names(datasets), collapse = ', ') } datasets.")
143	5x	checkmate::assert_list(data_extract, names = "named", types = c("list", "data_extract_spec", "NULL"))
144	3x	lapply(data_extract, function(x) {
145	6x	if (is.list(x) && !inherits(x, "data_extract_spec")) {
146	!	checkmate::assert_list(x, "data_extract_spec")
147		}
148		})
149
150	3x	selector_list <- data_extract_multiple_srv(data_extract, datasets, join_keys)
151
152	3x	merge_expression_srv(
153	3x	id = id,
154	3x	selector_list = selector_list,
155	3x	datasets = datasets,
156	3x	join_keys = join_keys,
157	3x	merge_function = merge_function,
158	3x	anl_name = anl_name
159		)
160		}
161
162
163		#' Data merge module server
164		#'
165		#' @description `r lifecycle::badge("experimental")`
166		#' @details When additional processing of the `data_extract` list input is required, `merge_expression_srv()` can be
167		#' combined with `data_extract_multiple_srv()` or `data_extract_srv()` to influence the `selector_list` input.
168		#' Compare the example below with that found in [merge_expression_module()].
169		#'
170		#' @inheritParams shiny::moduleServer
171		#' @param datasets (named `list` of `reactive` or non-`reactive` `data.frame`)\cr
172		#' object containing data as a list of `data.frame`. When passing a list of non-reactive `data.frame` objects, they are
173		#' converted to reactive `data.frame` objects internally.
174		#' @param join_keys (`JoinKeys`)\cr
175		#' of variables used as join keys for each of the datasets in `datasets`.
176		#' This will be used to extract the `keys` of every dataset.
177		#' @param selector_list (`reactive`)\cr
178		#' output from [data_extract_multiple_srv()] or a reactive named list of outputs from [data_extract_srv()].
179		#' When using a reactive named list, the names must be identical to the shiny ids of the respective
180		#' [data_extract_ui()].
181		#' @param merge_function (`character(1)` or `reactive`)\cr
182		#' A character string of a function that accepts the arguments
183		#' `x`, `y` and `by` to perform the merging of datasets.
184		#' @param anl_name (`character(1)`)\cr
185		#' Name of the analysis dataset.
186		#'
187		#' @return reactive expression with output from [merge_datasets()].
188		#'
189		#' @seealso [merge_expression_srv()]
190		#'
191		#' @export
192		#'
193		#' @examples
194		#' library(shiny)
195		#'
196		#' ADSL <- data.frame(
197		#' STUDYID = "A",
198		#' USUBJID = LETTERS[1:10],
199		#' SEX = rep(c("F", "M"), 5),
200		#' AGE = rpois(10, 30),
201		#' BMRKR1 = rlnorm(10)
202		#' )
203		#'
204		#' ADLB <- expand.grid(
205		#' STUDYID = "A",
206		#' USUBJID = LETTERS[1:10],
207		#' PARAMCD = c("ALT", "CRP", "IGA"),
208		#' AVISIT = c("SCREENING", "BASELINE", "WEEK 1 DAY 8", "WEEK 2 DAY 15")
209		#' )
210		#' ADLB$AVAL <- rlnorm(120)
211		#' ADLB$CHG <- rlnorm(120)
212		#'
213		#' data_list <- list(
214		#' ADSL = ADSL,
215		#' ADLB = ADLB
216		#' )
217		#'
218		#' join_keys <- teal.data::join_keys(
219		#' teal.data::join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")),
220		#' teal.data::join_key("ADSL", "ADLB", c("STUDYID", "USUBJID")),
221		#' teal.data::join_key("ADLB", "ADLB", c("STUDYID", "USUBJID", "PARAMCD", "AVISIT"))
222		#' )
223		#'
224		#' adsl_extract <- data_extract_spec(
225		#' dataname = "ADSL",
226		#' select = select_spec(
227		#' label = "Select variable:",
228		#' choices = c("AGE", "BMRKR1"),
229		#' selected = "AGE",
230		#' multiple = TRUE,
231		#' fixed = FALSE
232		#' )
233		#' )
234		#' adlb_extract <- data_extract_spec(
235		#' dataname = "ADLB",
236		#' filter = filter_spec(vars = "PARAMCD", choices = c("ALT", "CRP", "IGA"), selected = "ALT"),
237		#' select = select_spec(
238		#' label = "Select variable:",
239		#' choices = c("AVAL", "CHG"),
240		#' selected = "AVAL",
241		#' multiple = TRUE,
242		#' fixed = FALSE
243		#' )
244		#' )
245		#'
246		#' app <- shinyApp(
247		#' ui = fluidPage(
248		#' teal.widgets::standard_layout(
249		#' output = div(
250		#' verbatimTextOutput("expr"),
251		#' dataTableOutput("data")
252		#' ),
253		#' encoding = tagList(
254		#' data_extract_ui("adsl_var", label = "ADSL selection", adsl_extract),
255		#' data_extract_ui("adlb_var", label = "ADLB selection", adlb_extract)
256		#' )
257		#' )
258		#' ),
259		#' server = function(input, output, session) {
260		#' data_q <- teal.code::new_qenv()
261		#'
262		#' data_q <- teal.code::eval_code(
263		#' data_q,
264		#' "ADSL <- data.frame(
265		#' STUDYID = 'A',
266		#' USUBJID = LETTERS[1:10],
267		#' SEX = rep(c('F', 'M'), 5),
268		#' AGE = rpois(10, 30),
269		#' BMRKR1 = rlnorm(10)
270		#' )"
271		#' )
272		#'
273		#' data_q <- teal.code::eval_code(
274		#' data_q,
275		#' "ADLB <- expand.grid(
276		#' STUDYID = 'A',
277		#' USUBJID = LETTERS[1:10],
278		#' PARAMCD = c('ALT', 'CRP', 'IGA'),
279		#' AVISIT = c('SCREENING', 'BASELINE', 'WEEK 1 DAY 8', 'WEEK 2 DAY 15'),
280		#' AVAL = rlnorm(120),
281		#' CHG = rlnorm(120)
282		#' )"
283		#' )
284		#'
285		#' selector_list <- data_extract_multiple_srv(
286		#' list(adsl_var = adsl_extract, adlb_var = adlb_extract),
287		#' datasets = data_list
288		#' )
289		#' merged_data <- merge_expression_srv(
290		#' selector_list = selector_list,
291		#' datasets = data_list,
292		#' join_keys = join_keys,
293		#' merge_function = "dplyr::left_join"
294		#' )
295		#'
296		#' code_merge <- reactive({
297		#' for (exp in merged_data()$expr) data_q <- teal.code::eval_code(data_q, exp)
298		#' data_q
299		#' })
300		#'
301		#' output$expr <- renderText(paste(merged_data()$expr, collapse = "\n"))
302		#' output$data <- renderDataTable(code_merge()[["ANL"]])
303		#' }
304		#' )
305		#' \dontrun{
306		#' runApp(app)
307		#' }
308		merge_expression_srv <- function(id = "merge_id",
309		selector_list,
310		datasets,
311		join_keys,
312		merge_function = "dplyr::full_join",
313		anl_name = "ANL") {
314	23x	checkmate::assert_string(anl_name)
315	22x	stopifnot(make.names(anl_name) == anl_name)
316	19x	checkmate::assert_class(selector_list, "reactive")
317	17x	checkmate::assert_list(datasets, types = c("reactive", "data.frame"), names = "named")
318	15x	checkmate::assert_class(join_keys, "JoinKeys")
319
320	14x	moduleServer(
321	14x	id,
322	14x	function(input, output, session) {
323	14x	logger::log_trace(
324	14x	"merge_expression_srv initialized with: { paste(names(datasets), collapse = ', ') } datasets."
325		)
326
327		# convert to list of reactives
328	14x	datasets <- sapply(X = datasets, simplify = FALSE, FUN = function(x) {
329	2x	if (is.reactive(x)) x else reactive(x)
330		})
331
332	14x	reactive({
333	7x	checkmate::assert_list(selector_list(), names = "named", types = "reactive")
334	5x	merge_fun_name <- if (inherits(merge_function, "reactive")) merge_function() else merge_function
335	5x	check_merge_function(merge_fun_name)
336
337		# function to filter out selectors which are NULL or only have validator
338	5x	f <- function(x) {
339	7x	is.null(x) \|\| (length(names(x)) == 1 && names(x) == "iv")
340		}
341
342	5x	ds <- Filter(Negate(f), lapply(selector_list(), function(x) x()))
343	5x	validate(need(length(ds) > 0, "At least one dataset needs to be selected"))
344	5x	merge_datasets(
345	5x	selector_list = ds,
346	5x	datasets = datasets,
347	5x	join_keys = join_keys,
348	5x	merge_function = merge_fun_name,
349	5x	anl_name = anl_name
350		)
351		})
352		}
353		)
354		}

1		#' Resolve delayed inputs by evaluating the code within the provided datasets
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' @param x Object of class `delayed_data` to resolve.
6		#' @param datasets A named list of type `data.frame` to use for evaluation.
7		#' @param keys A named list of type `character` to be used as the keys for each dataset. The names of this
8		#' list must be exactly the same as for datasets.
9		#'
10		#' @return Resolved object.
11		#'
12		#' @examples
13		#' ADSL <- teal.transform::rADSL
14		#' attr(ADSL, "keys") <- teal.data::get_cdisc_keys("ADSL")
15		#' data_list <- list(ADSL = shiny::reactive(ADSL))
16		#' keys <- list(ADSL = attr(ADSL, "keys"))
17		#' shiny::isolate({
18		#' # value_choices example
19		#' v1 <- value_choices("ADSL", "SEX", "SEX")
20		#' v1
21		#' teal.transform:::resolve(v1, data_list, keys)
22		#'
23		#' # variable_choices example
24		#' v2 <- variable_choices("ADSL", c("BMRKR1", "BMRKR2"))
25		#' v2
26		#' teal.transform:::resolve(v2, data_list, keys)
27		#'
28		#' # data_extract_spec example
29		#' adsl_filter <- filter_spec(
30		#' vars = variable_choices("ADSL", "SEX"),
31		#' sep = "-",
32		#' choices = value_choices("ADSL", "SEX", "SEX"),
33		#' selected = "F",
34		#' multiple = FALSE,
35		#' label = "Choose endpoint and Censor"
36		#' )
37		#'
38		#' adsl_select <- select_spec(
39		#' label = "Select variable:",
40		#' choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
41		#' selected = "BMRKR1",
42		#' multiple = FALSE,
43		#' fixed = FALSE
44		#' )
45		#'
46		#' adsl_de <- data_extract_spec(
47		#' dataname = "ADSL",
48		#' select = adsl_select,
49		#' filter = adsl_filter
50		#' )
51		#'
52		#' teal.transform:::resolve(adsl_filter, data_list, keys)
53		#' teal.transform:::resolve(adsl_select, data_list, keys)
54		#' teal.transform:::resolve(adsl_de, data_list, keys)
55		#'
56		#' # nested list (arm_ref_comp)
57		#' arm_ref_comp <- list(
58		#' ARMCD = list(
59		#' ref = variable_choices("ADSL"),
60		#' comp = variable_choices("ADSL")
61		#' )
62		#' )
63		#'
64		#' teal.transform:::resolve(arm_ref_comp, data_list, keys)
65		#' })
66		resolve <- function(x, datasets, keys = NULL) {
67	313x	checkmate::assert_list(datasets, type = "reactive", min.len = 1, names = "named")
68	310x	checkmate::assert_list(keys, "character", names = "named", null.ok = TRUE)
69	308x	checkmate::assert(
70	308x	.var.name = "keys",
71	308x	checkmate::check_names(names(keys), subset.of = names(datasets)),
72	308x	checkmate::check_null(keys)
73		)
74
75	307x	UseMethod("resolve")
76		}
77
78		#' @export
79		resolve.delayed_variable_choices <- function(x, datasets, keys) { # nolint
80	112x	if (is.null(x$key)) {
81	110x	x$key <- `if`(is.null(keys), character(), keys[[x$data]])
82		}
83	112x	x$data <- datasets[[x$data]]()
84	112x	if (inherits(x$subset, "function")) {
85	38x	x$subset <- resolve_delayed_expr(x$subset, ds = x$data, is_value_choices = FALSE)
86		}
87	112x	return(do.call("variable_choices", x))
88		}
89
90		#' @export
91		resolve.delayed_value_choices <- function(x, datasets, keys) { # nolint
92	56x	x$data <- datasets[[x$data]]()
93	56x	if (is.function(x$subset)) {
94	28x	x$subset <- resolve_delayed_expr(x$subset, ds = x$data, is_value_choices = TRUE)
95		}
96	56x	return(do.call("value_choices", x))
97		}
98
99		#' @export
100		resolve.delayed_choices_selected <- function(x, datasets, keys) { # nolint
101	6x	if (inherits(x$selected, "delayed_data")) {
102	6x	x$selected <- resolve(x$selected, datasets = datasets, keys)
103		}
104	6x	x$choices <- resolve(x$choices, datasets = datasets, keys)
105
106	6x	if (!all(x$selected %in% x$choices)) {
107	2x	logger::log_warn(paste(
108	2x	"Removing",
109	2x	paste(x$selected[which(!x$selected %in% x$choices)]),
110	2x	"from 'selected' as not in 'choices' when resolving delayed choices_selected"
111		))
112	2x	x$selected <- x$selected[which(x$selected %in% x$choices)]
113		}
114
115	6x	return(do.call("choices_selected", x))
116		}
117
118		#' @export
119		resolve.delayed_select_spec <- function(x, datasets, keys) { # nolint
120	36x	x$choices <- resolve(x$choices, datasets = datasets, keys)
121	36x	if (inherits(x$selected, "delayed_data")) {
122	8x	x$selected <- resolve(x$selected, datasets = datasets, keys)
123		}
124	36x	return(do.call("select_spec", x))
125		}
126
127		#' @export
128		resolve.delayed_filter_spec <- function(x, datasets, keys) { # nolint
129	38x	if (inherits(x$vars_choices, "delayed_data")) {
130	22x	x$vars_choices <- resolve(x$vars_choices, datasets = datasets, keys)
131		}
132	38x	if (inherits(x$vars_selected, "delayed_data")) {
133	18x	x$vars_selected <- resolve(x$vars_selected, datasets = datasets, keys)
134		}
135	38x	if (inherits(x$choices, "delayed_data")) {
136	34x	x$choices <- resolve(x$choices, datasets = datasets, keys)
137		}
138	38x	if (inherits(x$selected, "delayed_data")) {
139	8x	x$selected <- resolve(x$selected, datasets = datasets, keys)
140		}
141
142	38x	return(do.call("filter_spec_internal", x[intersect(names(x), methods::formalArgs(filter_spec_internal))]))
143		}
144
145		#' @export
146		resolve.delayed_data_extract_spec <- function(x, datasets, keys) { # nolint
147	34x	x$select <- `if`(
148	34x	inherits(x$select, "delayed_data"),
149	34x	resolve(x$select, datasets = datasets, keys),
150	34x	x$select
151		)
152
153	34x	if (any(vapply(x$filter, inherits, logical(1L), "delayed_data"))) {
154	24x	idx <- vapply(x$filter, inherits, logical(1), "delayed_data")
155	24x	x$filter[idx] <- lapply(x$filter[idx], resolve, datasets = datasets, keys = keys)
156		}
157
158	34x	return(do.call("data_extract_spec", x))
159		}
160
161		#' @export
162		resolve.list <- function(x, datasets, keys) { # nolint
163		# If specified explicitly, return it unchanged. Otherwise if delayed, resolve.
164	17x	res <- lapply(x, resolve, datasets = datasets, keys = keys)
165	16x	return(res)
166		}
167
168		#' @export
169		resolve.default <- function(x, datasets, keys) {
170	8x	return(x)
171		}
172
173		#' Resolve expression after delayed data are loaded
174		#'
175		#'
176		#' @param x (`function`) Function that is applied on dataset.
177		#' It must take only a single argument "data" and return character vector with columns / values.
178		#' @param ds (`data.frame`) `TealDataset` on which the function is applied to.
179		#' @param is_value_choices (`logical`) Determines which check of the returned value will be applied.
180		#'
181		#' @return Character vector - result of calling function `x` on dataset `ds`.
182		#' @keywords internal
183		#'
184		#' @examples
185		#' \dontrun{
186		#' # get only possible factor variables from mtcars dataset
187		#' resolve_delayed_expr(
188		#' function(data) {
189		#' idx <- vapply(data, function(x) is.numeric(x) && length(unique(x)) <= 6, logical(1))
190		#' colnames(data)[idx]
191		#' },
192		#' ds = mtcars,
193		#' is_value_choices = FALSE
194		#' )
195		#' }
196		resolve_delayed_expr <- function(x, ds, is_value_choices) {
197	124x	checkmate::assert_function(x, args = "data", nargs = 1)
198
199		# evaluate function
200	118x	res <- do.call(x, list(data = ds))
201
202		# check returned value
203	118x	if (is_value_choices) {
204	52x	if (!is.atomic(res) \|\| anyDuplicated(res)) {
205	2x	stop(paste(
206	2x	"The following function must return a vector with unique values",
207	2x	"from the respective columns of the dataset.\n\n",
208	2x	deparse1(bquote(.(x)), collapse = "\n")
209		))
210		}
211		} else {
212	66x	if (!checkmate::test_character(res, any.missing = FALSE) \|\| length(res) > ncol(ds) \|\| anyDuplicated(res)) {
213	6x	stop(paste(
214	6x	"The following function must return a character vector with unique",
215	6x	"names from the available columns of the dataset:\n\n",
216	6x	deparse1(bquote(.(x)), collapse = "\n")
217		))
218		}
219		}
220
221	110x	return(res)
222		}
223
224		#' @keywords internal
225		#' @export
226		print.delayed_variable_choices <- function(x, indent = 0L, ...) {
227	!	cat(indent_msg(indent, paste("variable_choices with delayed data:", x$data)))
228	!	cat("\n")
229	!	print_delayed_list(x, indent)
230	!	return(invisible(NULL))
231		}
232
233		#' @keywords internal
234		#' @export
235		print.delayed_value_choices <- function(x, indent = 0L, ...) {
236	!	cat(indent_msg(indent, paste("value_choices with delayed data: ", x$data)))
237	!	cat("\n")
238	!	print_delayed_list(x, indent)
239	!	return(invisible(NULL))
240		}
241
242		#' @keywords internal
243		#' @export
244		print.delayed_choices_selected <- function(x, indent = 0L, ...) {
245	!	cat(indent_msg(indent, paste("choices_selected with delayed data: ", x$choices$data)))
246	!	cat("\n")
247	!	print_delayed_list(x, indent)
248	!	return(invisible(NULL))
249		}
250
251		#' @keywords internal
252		#' @export
253		print.delayed_select_spec <- function(x, indent = 0L, ...) {
254	!	cat(indent_msg(indent, paste("select_spec with delayed data:", x$choices$data)))
255	!	cat("\n")
256	!	print_delayed_list(x, indent)
257	!	return(invisible(NULL))
258		}
259
260		#' @keywords internal
261		#' @export
262		print.filter_spec <- function(x, indent = 0L, ...) {
263	!	cat(indent_msg(indent, "filter_spec with delayed data:"))
264	!	cat("\n")
265	!	print_delayed_list(x, indent)
266	!	return(invisible(NULL))
267		}
268
269		#' @keywords internal
270		#' @export
271		print.delayed_filter_spec <- function(x, indent = 0L, ...) {
272	!	cat(indent_msg(indent, "filter_spec with delayed data:"))
273	!	cat("\n")
274	!	print_delayed_list(x, indent)
275	!	return(invisible(NULL))
276		}
277
278		#' @keywords internal
279		#' @export
280		print.delayed_data_extract_spec <- function(x, indent = 0L, ...) {
281	!	cat(paste("data_extract_spec with delayed data:", x$dataname))
282	!	cat("\n\n")
283	!	print_delayed_list(x)
284	!	return(invisible(NULL))
285		}
286
287		indent_msg <- function(n, msg) {
288	!	checkmate::assert_integer(n, len = 1, lower = 0, any.missing = FALSE)
289	!	checkmate::assert_character(msg, min.len = 1, any.missing = FALSE)
290	!	indent <- paste(rep(" ", n), collapse = "")
291	!	return(paste0(indent, msg))
292		}
293
294		print_delayed_list <- function(obj, n = 0L) {
295	!	checkmate::assert_integer(n, len = 1, lower = 0, any.missing = FALSE)
296	!	stopifnot(is.list(obj))
297
298	!	for (idx in seq_along(obj)) {
299	!	cat(indent_msg(n, ifelse(is.null(names(obj)[[idx]]), paste0("[[", idx, "]]"), paste("$", names(obj)[[idx]]))))
300	!	cat("\n")
301	!	if (inherits(obj[[idx]], "delayed_data")) {
302	!	print(obj[[idx]], n + 1L)
303	!	} else if (is.list(obj[[idx]])) {
304	!	print_delayed_list(obj[[idx]], n + 1L)
305		} else {
306	!	cat(indent_msg(n, paste(utils::capture.output(print(obj[[idx]])), collapse = "\n")))
307	!	cat("\n")
308		}
309		}
310	!	return(invisible(NULL))
311		}

1		#' Checks `varname` argument and convert to call
2		#'
3		#' Checks `varname` type and parse if it's a `character`
4		#' @param varname (`name`, `call` or `character(1)`)\cr
5		#' name of the variable
6		#' @keywords internal
7		call_check_parse_varname <- function(varname) {
8	188x	checkmate::assert(
9	188x	checkmate::check_string(varname),
10	188x	checkmate::check_class(varname, "call"),
11	188x	checkmate::check_class(varname, "name")
12		)
13	188x	if (is.character(varname)) {
14	!	parsed <- parse(text = varname, keep.source = FALSE)
15	!	if (length(parsed) == 1) {
16	!	varname <- parsed[[1]]
17		} else {
18	!	stop(
19	!	sprintf(
20	!	"Problem with parsing '%s'. Not able to process multiple calls",
21	!	varname
22		)
23		)
24		}
25		}
26	188x	varname
27		}
28
29		#' Choices condition call
30		#'
31		#' Compose choices condition call from inputs.
32		#'
33		#' @param varname (`name`, `call` or `character(1)`)\cr
34		#' name of the variable
35		#'
36		#' @param choices (`vector`)\cr
37		#' `varname` values to match using the `==` (single value) or
38		#' `%in%` (vector) condition. `choices` can be vector of any type
39		#' but for some output might be converted:
40		#' \itemize{
41		#' \item{`factor`}{ call is composed on choices converted to `character`}
42		#' \item{`Date`}{ call is composed on choices converted to `character` using `format(choices)`}
43		#' \item{`POSIXct`, `POSIXlt`}{ Call is composed on choices converted to `character` using
44		#' `format(choices)`. One has to be careful here as formatted date-time variable might loose
45		#' some precision (see `format` argument in \code{\link{format.POSIXlt}}) and output call
46		#' could be insufficient for exact comparison. In this case one should specify
47		#' `varname = trunc(<varname>)` and possibly convert `choices` to `character`)
48		#' }
49		#' }
50		#'
51		#' @examples
52		#' teal.transform:::call_condition_choice("SEX", choices = c(1, 2))
53		#' teal.transform:::call_condition_choice(as.name("SEX"), choices = "F")
54		#' teal.transform:::call_condition_choice("SEX", choices = c("F", "M"))
55		#' teal.transform:::call_condition_choice("SEX", choices = factor(c("F", "M")))
56		#' teal.transform:::call_condition_choice("x$SEX", choices = Sys.Date())
57		#' teal.transform:::call_condition_choice("trunc(x$SEX)", choices = Sys.time())
58		#' @return a `call`
59		#' @keywords internal
60		call_condition_choice <- function(varname, choices) {
61	188x	varname <- call_check_parse_varname(varname)
62
63	188x	if (is.factor(choices)) {
64	!	choices <- as.character(choices)
65	188x	} else if (inherits(choices, "Date")) {
66	!	choices <- format(choices)
67	188x	} else if (inherits(choices, c("POSIXct", "POSIXlt"))) {
68	!	choices <- format(choices)
69		}
70
71
72	188x	if (length(choices) == 1) {
73	134x	call("==", varname, choices)
74		} else {
75	54x	c_call <- do.call(
76	54x	"call",
77	54x	append(list("c"), choices)
78		)
79		# c_call needed because it needs to be vector call
80		# instead of vector. SummarizedExperiment.subset
81		# handles only vector calls
82	54x	call("%in%", varname, c_call)
83		}
84		}
85
86		#' `numeric` range condition call
87		#'
88		#' Compose `numeric` range condition call from inputs
89		#'
90		#' @param varname (`name` or `character(1)`)\cr
91		#' name of the variable
92		#'
93		#' @param range (`numeric(2)`)\cr
94		#' range of the variable
95		#'
96		#' @return call
97		#' @examples
98		#' teal.transform:::call_condition_range("AGE", range = c(1, 2))
99		#' teal.transform:::call_condition_range(as.name("AGE"), range = c(-1.2, 2.1))
100		#' teal.transform:::call_condition_range(
101		#' teal.transform:::call_extract_list("ADSL", "AGE"),
102		#' range = c(-1.2, 2.1)
103		#' )
104		#' @return a `call`
105		#' @keywords internal
106		call_condition_range <- function(varname, range) {
107	!	checkmate::assert_numeric(range, len = 2, sorted = TRUE)
108
109	!	varname <- call_check_parse_varname(varname)
110	!	call(
111		"&",
112	!	call(">=", varname, range[1]),
113	!	call("<=", varname, range[2])
114		)
115		}
116
117		#' `logical` variable condition call
118		#'
119		#' Compose `logical` variable condition call from inputs
120		#'
121		#' @param varname (`name` or `character(1)`)\cr
122		#' name of the variable
123		#'
124		#' @param choice (`logical(1)`)\cr
125		#' chosen value
126		#'
127		#' @return call
128		#' @examples
129		#' teal.transform:::call_condition_logical("event", choice = TRUE)
130		#' teal.transform:::call_condition_logical("event", choice = FALSE)
131		#' @return a `call`
132		#' @keywords internal
133		call_condition_logical <- function(varname, choice) {
134	!	checkmate::assert_flag(choice)
135	!	varname <- call_check_parse_varname(varname)
136
137	!	if (choice) {
138	!	varname
139	!	} else if (!choice) {
140	!	call("!", varname)
141		} else {
142	!	stop(
143	!	"Unknown filter state", toString(choice),
144	!	" for logical var ", as.character(varname)
145		)
146		}
147		}
148
149
150		#' `POSIXct` range condition call
151		#'
152		#' Compose `POSIXct` range condition call from inputs.
153		#'
154		#' @param varname (`name` or `character(1)`)\cr
155		#' name of the variable
156		#'
157		#' @param range (`POSIXct`)\cr
158		#' range of the variable. Be aware that output
159		#' uses truncated range format `"%Y-%m-%d %H:%M:%S"`, which means that
160		#' some precision might be lost.
161		#'
162		#' @param timezone (`character(1)`)\cr
163		#' specifies the time zone to be used for the conversion.
164		#' By default `Sys.timezone()` is used.
165		#'
166		#' @examples
167		#' teal.transform:::call_condition_range_posixct(
168		#' varname = as.name("datetime"),
169		#' range = c(Sys.time(), Sys.time() + 1),
170		#' timezone = "UTC"
171		#' )
172		#' @return a `call`
173		#' @keywords internal
174		call_condition_range_posixct <- function(varname, range, timezone = Sys.timezone()) {
175	!	checkmate::assert_posixct(range, len = 2, sorted = TRUE)
176	!	checkmate::assert_string(timezone)
177	!	varname <- call_check_parse_varname(varname)
178
179	!	range[1] <- trunc(range[1], units = c("secs"))
180	!	range[2] <- trunc(range[2] + 1, units = c("secs"))
181
182	!	range <- format(
183	!	range,
184	!	format = "%Y-%m-%d %H:%M:%S",
185	!	tz = timezone
186		)
187
188	!	call(
189		"&",
190	!	call(">=", varname, call("as.POSIXct", range[1], tz = timezone)),
191	!	call("<", varname, call("as.POSIXct", range[2], tz = timezone))
192		)
193		}
194
195		#' `Date` range condition call
196		#'
197		#' Compose `Date` range condition call from inputs
198		#'
199		#' @param varname (`name` or `character(1)`)\cr
200		#' name of the variable
201		#'
202		#' @param range (`Date`)\cr
203		#' range of the variable
204		#'
205		#' @examples
206		#' teal.transform:::call_condition_range_date(
207		#' as.name("date"),
208		#' range = c(Sys.Date(), Sys.Date() + 1)
209		#' )
210		#' @return a `call`
211		#' @keywords internal
212		call_condition_range_date <- function(varname, range) {
213	!	checkmate::assert_date(range, len = 2)
214	!	checkmate::assert_true(range[2] >= range[1])
215	!	varname <- call_check_parse_varname(varname)
216
217	!	call(
218		"&",
219	!	call(">=", varname, call("as.Date", as.character(range[1]))),
220	!	call("<=", varname, call("as.Date", as.character(range[2])))
221		)
222		}
223
224		#' Get call to subset and select array
225		#'
226		#' Get call to subset and select array
227		#' @param dataname (`character(1)` or `name`)\cr
228		#' @param row (`name`, `call`, `logical`, `integer`, `character`)\cr
229		#' optional, name of the `row` or condition
230		#' @param column (`name`, `call`, `logical`, `integer`, `character`)\cr
231		#' optional, name of the `column` or condition
232		#' @param aisle (`name`, `call`, `logical`, `integer`, `character`)\cr
233		#' optional, name of the `row` or condition
234		#' @return `[` call with all conditions included
235		#' @examples
236		#' teal.transform:::call_extract_array(
237		#' dataname = "my_array",
238		#' row = teal.transform:::call_condition_choice("my_array$SEX", "M"),
239		#' column = call("c", "SEX", "AGE"),
240		#' aisle = "RNAseq_rnaaccess"
241		#' )
242		#' teal.transform:::call_extract_array(
243		#' "mae_object",
244		#' column = teal.transform:::call_condition_choice("SEX", "M")
245		#' )
246		#' @return specific \code{\link[base]{Extract}} `call` for 3-dimensional array
247		#' @keywords internal
248		call_extract_array <- function(dataname = ".", row = NULL, column = NULL, aisle = NULL) {
249	!	checkmate::assert(
250	!	checkmate::check_string(dataname),
251	!	checkmate::check_class(dataname, "call"),
252	!	checkmate::check_class(dataname, "name")
253		)
254	!	stopifnot(is.null(row) \|\| is.call(row) \|\| is.character(row) \|\| is.logical(row) \|\| is.integer(row) \|\| is.name(row))
255	!	stopifnot(is.null(column) \|\| is.call(column) \|\| is.vector(column) \|\| is.name(column))
256	!	stopifnot(is.null(aisle) \|\| is.call(aisle) \|\| is.vector(aisle) \|\| is.name(aisle))
257
258	!	if (is.language(dataname)) {
259	!	dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n")
260		}
261
262	!	row <- if (is.null(row)) {
263		""
264		} else {
265	!	paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n")
266		}
267	!	column <- if (is.null(column)) {
268		""
269		} else {
270	!	paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n")
271		}
272	!	aisle <- if (is.null(aisle)) {
273		""
274		} else {
275	!	paste(trimws(deparse(aisle, width.cutoff = 500L)), collapse = "\n")
276		}
277
278	!	parse(
279	!	text = sprintf("%s[%s, %s, %s]", dataname, row, column, aisle),
280	!	keep.source = FALSE
281	!	)[[1]]
282		}
283
284		#' Get call to subset and select matrix
285		#'
286		#' Get call to subset and select matrix
287		#' @param dataname (`character(1)` or `name`)\cr
288		#' @param row (`name`, `call`, `logical`, `integer`, `character`)\cr
289		#' optional, name of the `row` or condition
290		#' @param column (`name`, `call`, `logical`, `integer`, `character`)\cr
291		#' optional, name of the `column` or condition
292		#' @return `[` call with all conditions included
293		#' @examples
294		#' teal.transform:::call_extract_matrix(
295		#' dataname = "my_array",
296		#' row = teal.transform:::call_condition_choice("my_array$SEX", "M"),
297		#' column = call("c", "SEX", "AGE")
298		#' )
299		#' teal.transform:::call_extract_matrix(
300		#' "mae_object",
301		#' column = teal.transform:::call_condition_choice("SEX", "M")
302		#' )
303		#' @return specific \code{\link[base]{Extract}} `call` for matrix
304		#' @keywords internal
305		call_extract_matrix <- function(dataname = ".", row = NULL, column = NULL) {
306	!	checkmate::assert(
307	!	checkmate::check_string(dataname),
308	!	checkmate::check_class(dataname, "call"),
309	!	checkmate::check_class(dataname, "name")
310		)
311	!	stopifnot(is.null(row) \|\| is.call(row) \|\| is.character(row) \|\| is.logical(row) \|\| is.integer(row) \|\| is.name(row))
312	!	stopifnot(is.null(column) \|\| is.call(column) \|\| is.vector(column) \|\| is.name(column))
313
314	!	if (is.language(dataname)) {
315	!	dataname <- paste(trimws(deparse(dataname, width.cutoff = 500L)), collapse = "\n")
316		}
317
318	!	row <- if (is.null(row)) {
319		""
320		} else {
321	!	paste(trimws(deparse(row, width.cutoff = 500L)), collapse = "\n")
322		}
323	!	column <- if (is.null(column)) {
324		""
325		} else {
326	!	paste(trimws(deparse(column, width.cutoff = 500L)), collapse = "\n")
327		}
328
329	!	parse(
330	!	text = sprintf("%s[%s, %s]", dataname, row, column),
331	!	keep.source = FALSE
332	!	)[[1]]
333		}
334
335
336		#' Compose extract call with `$` operator
337		#'
338		#' Compose extract call with `$` operator
339		#'
340		#' @param dataname (`character(1)` or `name`)\cr
341		#' name of the object
342		#'
343		#' @param varname (`character(1)` or `name`)\cr
344		#' name of the slot in data
345		#'
346		#' @param dollar (`logical(1)`)\cr
347		#' whether returned call should use `$` or `[[` operator
348		#'
349		#' @return `$` or `[[` call
350		#' @examples
351		#' teal.transform:::call_extract_list("ADSL", "SEX")
352		#' teal.transform:::call_extract_list("ADSL", "named element")
353		#' teal.transform:::call_extract_list(as.name("ADSL"), as.name("AGE"))
354		#' teal.transform:::call_extract_list(as.name("weird name"), as.name("AGE"))
355		#' teal.transform:::call_extract_list(as.name("ADSL"), "AGE", dollar = FALSE)
356		#' @keywords internal
357		call_extract_list <- function(dataname, varname, dollar = TRUE) {
358	!	checkmate::assert_flag(dollar)
359	!	checkmate::assert(
360	!	checkmate::check_string(varname),
361	!	checkmate::check_class(varname, "name"),
362	!	checkmate::assert(
363	!	combine = "and",
364	!	checkmate::check_class(varname, "call"),
365	!	checkmate::check_false(dollar)
366		)
367		)
368
369	!	dataname <- call_check_parse_varname(dataname)
370
371	!	if (dollar) {
372	!	call("$", dataname, varname)
373		} else {
374	!	call("[[", dataname, varname)
375		}
376		}
377
378		#' Create a call using a function in a given namespace
379		#'
380		#' The arguments in ... need to be quoted because they will be evaluated otherwise
381		#'
382		#' @md
383		#' @param name `character` function name, possibly using namespace colon `::`, also
384		#' works with `:::` (sometimes needed, but strongly discouraged)
385		#' @param ... arguments to pass to function with name `name`
386		#' @param unlist_args `list` extra arguments passed in a single list,
387		#' avoids the use of `do.call` with this function
388		#' @examples
389		#'
390		#' print_call_and_eval <- function(x) {
391		#' eval(print(x))
392		#' }
393		#'
394		#' print_call_and_eval(
395		#' teal.transform:::call_with_colon("glue::glue", "x = {x}", x = 10)
396		#' )
397		#' \dontrun{
398		#' # mtcars$cyl evaluated
399		#' print_call_and_eval(
400		#' teal.transform:::call_with_colon("dplyr::filter", as.name("mtcars"), mtcars$cyl == 6)
401		#' )
402		#'
403		#' # mtcars$cyl argument not evaluated immediately (in call expression)
404		#' print_call_and_eval(
405		#' teal.transform:::call_with_colon("dplyr::filter", as.name("mtcars"), quote(cyl == 6))
406		#' )
407		#'
408		#' # does not work because argument is evaluated and the
409		#' # non-dplyr filter does not look inside mtcars
410		#' # cannot eval because it does not pass checks because of non-standard evaluation
411		#' call("filter", as.name("mtcars"), quote(cyl == 6))
412		#' # works, but non-dplyr filter is taken
413		#' call("filter", as.name("mtcars"), mtcars$cyl == 6)
414		#'
415		#' nb_args <- function(...) nargs()
416		#' print_call_and_eval(
417		#' teal.transform:::call_with_colon("nb_args", arg1 = 1, unlist_args = list(arg2 = 2, args3 = 3))
418		#' )
419		#' # duplicate arguments
420		#' print_call_and_eval(
421		#' teal.transform:::call_with_colon("nb_args", arg1 = 1, unlist_args = list(arg2 = 2, args2 = 2))
422		#' )
423		#' }
424		#' @keywords internal
425		call_with_colon <- function(name, ..., unlist_args = list()) {
426	!	checkmate::assert_string(name)
427	!	checkmate::assert_list(unlist_args)
428	!	as.call(c(
429	!	parse(text = name, keep.source = FALSE)[[1]],
430	!	c(list(...), unlist_args)
431		))
432		}
433
434
435		#' Combine calls by operator
436		#'
437		#' Combine list of calls by specific operator
438		#'
439		#' @param operator (`character(1)` or `name`)\cr
440		#' name/symbol of the operator.
441		#'
442		#' @param calls (`list` of calls)\cr
443		#' list containing calls to be combined by `operator`
444		#'
445		#' @return call
446		#' @examples
447		#' teal.transform:::calls_combine_by(
448		#' "&",
449		#' calls = list(
450		#' teal.transform:::call_condition_choice("SEX", "F"),
451		#' teal.transform:::call_condition_range("AGE", c(20, 50)),
452		#' teal.transform:::call_condition_choice("ARM", "ARM: A"),
453		#' TRUE
454		#' )
455		#' )
456		#' @return a combined `call`
457		#' @keywords internal
458		calls_combine_by <- function(operator, calls) {
459	98x	checkmate::assert_string(operator)
460	98x	stopifnot(
461	98x	all(
462	98x	vapply(
463	98x	X = calls,
464	98x	FUN.VALUE = logical(1),
465	98x	FUN = function(x) is.language(x) \|\| is.logical(x)
466		)
467		)
468		)
469
470	98x	Reduce(
471	98x	x = calls,
472	98x	f = function(x, y) call(operator, x, y)
473		)
474		}

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

1		#' Returns non-key column names from data
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' @export
5		#'
6		#' @param data (\code{data.frame}) Data with attribute \code{filter_and_columns}. This can only be
7		#' created by \code{\link{data_extract_srv}}. which returns a shiny \code{\link[shiny]{reactive}}.
8		#'
9		#' @return A named character vector with the non-key columns of the \code{data}..
10		#'
11		#' @references \link{data_extract_srv}
12		get_dataset_prefixed_col_names <- function(data) {
13	!	if (!is.null(attr(data, "filter_and_columns")$columns) && attr(data, "filter_and_columns")$columns != "") {
14	!	paste(attr(data, "dataname"), attr(data, "filter_and_columns")$columns, sep = ".")
15		} else {
16	!	NULL
17		}
18		}

1		#' Data extract filter specification
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' It consists in choices and additionally the variable names for the choices
5		#'
6		#' @export
7		#'
8		#' @inheritParams select_spec
9		#'
10		#' @param vars (\code{character}) or (\code{delayed_data}) object.
11		#' Character vector giving the columns to be filtered. These should be
12		#' key variables of the data set to be filtered.
13		#' \code{delayed_data} objects can be created via [variable_choices()], [value_choices()],
14		#' or \code{\link{choices_selected}}.
15		#' @param sep (\code{character}) A separator string to split the \code{choices} or
16		#' \code{selected} inputs into the values of the different columns
17		#' @param choices (\code{character} or \code{numeric} or \code{logical} or (\code{delayed_data}) object.
18		#' Named character vector to define the choices
19		#' of a shiny \code{\link[shiny]{selectInput}}. These choices will be used to filter the
20		#' dataset.
21		#'
22		#' These shall be filter values of the \code{vars} input separated by the separator(\code{sep}). Please
23		#' watch out that the filter values have to follow the order of the \code{vars} input. In the following
24		#' example we will show how to filter two columns:
25		#'
26		#' \code{vars = c("PARAMCD","AVISIT")} and \code{choices = c("CRP - BASELINE", "ALT - BASELINE")}
27		#' will lead to a filtering of
28		#' \code{(PARAMCD == "CRP" & AVISIT == "BASELINE") \| (PARAMCD == "ALT" & AVISIT == "BASELINE")}.
29		#'
30		#' The \code{sep} input has to be \code{" - "} in this case.
31		#'
32		#' \code{delayed_data} objects can be created via \code{\link{variable_choices}} or \code{\link{value_choices}}.
33		#'
34		#' @param selected (\code{character} or \code{numeric} or \code{logical} or
35		#' (\code{delayed_data} or (\code{all_choices})) object.
36		#' Named character vector to define the selected
37		#' values of a shiny \code{\link[shiny]{selectInput}} (default values). This value will
38		#' be displayed inside the shiny app upon start. The `all_choices` object indicates selecting
39		#' all possible choices.
40		#'
41		#' @param drop_keys optional, (\code{logical}) whether to drop filter column from the dataset keys,
42		#' \code{TRUE} on default.
43		#'
44		#' @param label optional (\code{character}). Define a label on top of this specific
45		#' shiny \code{\link[shiny]{selectInput}}. The default value is \code{"Filter by"}.
46		#'
47		#' @return \code{filter_spec}-S3-class object or \code{delayed_filter_spec}-S3-class object.
48		#'
49		#' @details
50		#'
51		#' The \code{filter_spec} is used inside \code{teal} apps to allow filtering datasets
52		#' for their key variables. Imagine having an adverse events table. It has
53		#' the columns \code{PARAMCD} and \code{CNSR}. \code{PARAMCD} contains the levels
54		#' \code{"OS"}, \code{"PFS"}, \code{"EFS"}. \code{CNSR} contains the levels \code{"0"} and \code{"1"}.
55		#' The first example should show how a \code{filter_spec} setup will influence
56		#' the drop-down menu the app user will see.
57		#'
58		#'
59		#' @examples
60		#' # for Adverse Events table
61		#' filter_spec(
62		#' vars = c("PARAMCD", "CNSR"),
63		#' sep = "-",
64		#' choices = c("OS-1" = "OS-1", "OS-0" = "OS-0", "PFS-1" = "PFS-1"),
65		#' selected = "OS-1",
66		#' multiple = FALSE,
67		#' label = "Choose endpoint and Censor"
68		#' )
69		#'
70		#' # filtering a single variable
71		#' filter_spec(
72		#' vars = c("PARAMCD"),
73		#' sep = "-",
74		#' choices = c("OS", "PFS", "EFS"),
75		#' selected = "OS",
76		#' multiple = FALSE,
77		#' label = "Choose endpoint"
78		#' )
79		#'
80		#' # filtering a single variable by multiple levels of the variable
81		#' filter_spec(
82		#' vars = c("PARAMCD"),
83		#' sep = "-",
84		#' choices = c("OS", "PFS", "EFS"),
85		#' selected = c("OS", "PFS"),
86		#' multiple = TRUE,
87		#' label = "Choose endpoint"
88		#' )
89		#'
90		#' # delayed version
91		#' filter_spec(
92		#' vars = variable_choices("ADSL", "SEX"),
93		#' sep = "-",
94		#' choices = value_choices("ADSL", "SEX", "SEX"),
95		#' selected = "F",
96		#' multiple = FALSE,
97		#' label = "Choose endpoint and Censor"
98		#' )
99		#' # using `choices_selected()`
100		#' filter_spec(
101		#' vars = choices_selected(variable_choices("ADSL", subset = c("SEX", "AGE")), "SEX", fixed = FALSE),
102		#' multiple = TRUE
103		#' )
104		#'
105		#' filter_spec(
106		#' vars = choices_selected(variable_choices("ADSL"), "SEX", fixed = TRUE),
107		#' multiple = TRUE
108		#' )
109		#'
110		#' # choose all choices
111		#' adsl_filter <- filter_spec(
112		#' vars = choices_selected(variable_choices("ADSL"), "SEX", fixed = FALSE),
113		#' choices = value_choices("ADSL", "SEX"),
114		#' selected = all_choices()
115		#' )
116		filter_spec <- function(vars,
117		choices = NULL,
118		selected = `if`(inherits(choices, "delayed_data"), NULL, choices[1]),
119		multiple = length(selected) > 1 \|\| inherits(selected, "all_choices"),
120		label = "Filter by",
121		sep = attr(choices, "sep"),
122		drop_keys = FALSE) {
123	69x	if (is.null(sep)) sep <- " - "
124	109x	checkmate::assert(
125	109x	checkmate::check_character(vars, min.len = 1, any.missing = FALSE),
126	109x	checkmate::check_class(vars, "delayed_data"),
127	109x	checkmate::check_class(vars, "choices_selected")
128		)
129	106x	checkmate::assert(
130	106x	checkmate::check_null(choices),
131	106x	checkmate::check_character(choices, min.len = 1, any.missing = FALSE),
132	106x	checkmate::check_numeric(choices, min.len = 1, any.missing = FALSE),
133	106x	checkmate::check_logical(choices, min.len = 1, any.missing = FALSE),
134	106x	checkmate::check_class(choices, "delayed_data")
135		)
136	104x	checkmate::assert(
137	104x	checkmate::check_null(selected),
138	104x	checkmate::check_character(selected, min.len = 1, any.missing = FALSE),
139	104x	checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
140	104x	checkmate::check_logical(selected, min.len = 1, any.missing = FALSE),
141	104x	checkmate::check_class(selected, "delayed_data"),
142	104x	checkmate::check_class(selected, "all_choices")
143		)
144
145	103x	checkmate::assert_flag(multiple)
146	102x	checkmate::assert_string(label, null.ok = TRUE)
147	100x	checkmate::assert_string(sep)
148	99x	checkmate::assert_flag(drop_keys)
149	99x	stopifnot(multiple \|\| !inherits(selected, "all_choices"))
150
151	1x	if (inherits(selected, "all_choices") && !is.null(choices)) selected <- choices
152
153	99x	if (inherits(vars, "choices_selected")) {
154	8x	filter_spec_internal(
155	8x	vars_choices = vars$choices,
156	8x	vars_selected = vars$selected,
157	8x	vars_label = if (vars$fixed) NULL else label,
158	8x	vars_fixed = vars$fixed,
159	8x	vars_multiple = if (is.null(vars$selected)) FALSE else length(vars$selected) > 1,
160	8x	choices = choices,
161	8x	selected = selected,
162	8x	label = if (vars$fixed) label else NULL,
163	8x	fixed = FALSE,
164	8x	multiple = multiple,
165	8x	sep = sep,
166	8x	drop_keys = drop_keys
167		)
168		} else {
169	91x	filter_spec_internal(
170	91x	vars_choices = vars,
171	91x	vars_selected = vars,
172	91x	vars_label = NULL,
173	91x	vars_fixed = TRUE,
174	91x	vars_multiple = TRUE,
175	91x	choices = choices,
176	91x	selected = selected,
177	91x	label = label,
178	91x	fixed = FALSE,
179	91x	multiple = multiple,
180	91x	sep = sep,
181	91x	drop_keys = drop_keys
182		)
183		}
184		}
185
186
187		#' Data extract dynamic filter specification
188		#'
189		#' This function returns a configuration for the \code{data_extract_ui} module. This function covers
190		#' the configuration of filtering datasets (so called `filter_spec`), which then is used to build
191		#' the UI element in the `teal` app.
192		#'
193		#' @inheritParams filter_spec
194		#' @param vars_choices (`character` or `delayed_data`) \cr
195		#' the vector of dataset column names available to build dynamic filter
196		#' \code{delayed_data} objects can be created via \code{\link{variable_choices}}.
197		#' @param vars_selected (`NULL` or named `character`) \cr
198		#' the selected column name out from `choices`.
199		#' @param vars_label (`character`)\cr
200		#' the title printed on the UI element generated on the basis of this \code{filter_spec}.
201		#' @param vars_fixed (`logical`)\cr
202		#' if true allow to change the selected variables in the UI element; otherwise, do not allow.
203		#' @param vars_multiple (`logical`)\cr
204		#' if true allow to select multiple variables in the UI elements; otherwise, do not allow.
205		#' @param fixed (`logical`)\cr
206		#' if true allow to change the initially selected values of the variables; otherwise, do not allow.
207		#' @param dataname (`character`)\cr
208		#' the name of the dataset this filter covers. Set during the initialization of the teal application.
209		#' @param initialized (`logical`)\cr
210		#' indicates whether this filter was already initialized in the application.
211		#' TRUE if this filter was already consumed by the server function; FALSE otherwise.
212		#'
213		#' @return `filter_spec` or `delayed_filter_spec` S3-class object.
214		#' @keywords internal
215		#'
216		#' @seealso filter_spec
217		#'
218		#' @examples
219		#' teal.transform:::filter_spec_internal(
220		#' vars_choices = c("PARAMCD", "AVISIT"),
221		#' vars_selected = "PARAMCD",
222		#' vars_multiple = TRUE
223		#' )
224		#'
225		#' ADRS <- teal.transform::rADRS
226		#' teal.transform:::filter_spec_internal(
227		#' vars_choices = variable_choices(ADRS),
228		#' vars_selected = "PARAMCD",
229		#' vars_multiple = TRUE
230		#' )
231		#'
232		#' teal.transform:::filter_spec_internal(
233		#' vars_choices = variable_choices("ADRS"),
234		#' vars_selected = "PARAMCD",
235		#' vars_multiple = TRUE
236		#' )
237		filter_spec_internal <- function(vars_choices,
238		vars_selected = NULL,
239		vars_label = NULL,
240		vars_fixed = FALSE,
241		vars_multiple = TRUE,
242		choices = NULL,
243		selected = NULL,
244		label = NULL,
245		fixed = FALSE,
246		multiple = TRUE,
247		sep = attr(vars_choices, "sep"),
248		drop_keys = FALSE,
249		dataname = NULL,
250		initialized = FALSE) {
251	12x	if (is.null(sep)) sep <- " - "
252	149x	checkmate::assert_string(vars_label, null.ok = TRUE)
253	149x	checkmate::assert_flag(vars_fixed)
254	149x	checkmate::assert_flag(vars_multiple)
255	149x	checkmate::assert_string(label, null.ok = TRUE)
256	149x	checkmate::assert_flag(fixed)
257	149x	checkmate::assert_flag(multiple)
258	149x	checkmate::assert_string(sep)
259	149x	checkmate::assert_flag(drop_keys)
260
261	149x	if (inherits(vars_choices, "delayed_data") \|\|
262	149x	inherits(vars_selected, "delayed_data") \|\|
263	149x	inherits(choices, "delayed_data") \|\|
264	149x	inherits(selected, "delayed_data")) {
265	39x	filter_spec_internal.delayed_data(
266	39x	vars_choices = vars_choices,
267	39x	vars_selected = vars_selected,
268	39x	vars_label = vars_label,
269	39x	vars_fixed = vars_fixed,
270	39x	vars_multiple = vars_multiple,
271	39x	choices = choices,
272	39x	selected = selected,
273	39x	label = label,
274	39x	multiple = multiple,
275	39x	fixed = fixed,
276	39x	sep = sep,
277	39x	drop_keys = drop_keys,
278	39x	dataname = dataname,
279	39x	initialized = initialized
280		)
281		} else {
282	110x	UseMethod("filter_spec_internal")
283		}
284		}
285
286		#' @rdname filter_spec_internal
287		#' @export
288		filter_spec_internal.delayed_data <- function(vars_choices, # nolint
289		vars_selected = NULL,
290		vars_label = NULL,
291		vars_fixed = FALSE,
292		vars_multiple = TRUE,
293		choices = NULL,
294		selected = NULL,
295		label = NULL,
296		fixed = FALSE,
297		multiple = TRUE,
298		sep = attr(vars_choices, "sep"),
299		drop_keys = FALSE,
300		dataname = NULL,
301		initialized = FALSE) {
302	!	if (is.null(sep)) sep <- " - "
303	39x	checkmate::assert(
304	39x	checkmate::check_character(vars_choices, min.len = 1, any.missing = FALSE),
305	39x	checkmate::check_numeric(vars_choices, min.len = 1, any.missing = FALSE),
306	39x	checkmate::check_logical(vars_choices, min.len = 1, any.missing = FALSE),
307	39x	checkmate::check_class(vars_choices, "delayed_data")
308		)
309
310	39x	checkmate::assert(
311	39x	checkmate::check_null(vars_selected),
312	39x	checkmate::check_character(vars_selected, min.len = 1, any.missing = FALSE),
313	39x	checkmate::check_numeric(vars_selected, min.len = 1, any.missing = FALSE),
314	39x	checkmate::check_logical(vars_selected, min.len = 1, any.missing = FALSE),
315	39x	checkmate::check_class(vars_selected, "delayed_data")
316		)
317
318	39x	checkmate::assert(
319	39x	checkmate::check_null(choices),
320	39x	checkmate::check_character(choices, min.len = 1, any.missing = FALSE),
321	39x	checkmate::check_numeric(choices, min.len = 1, any.missing = FALSE),
322	39x	checkmate::check_logical(choices, min.len = 1, any.missing = FALSE),
323	39x	checkmate::check_class(choices, "delayed_data")
324		)
325
326	39x	checkmate::assert(
327	39x	checkmate::check_null(selected),
328	39x	checkmate::check_character(selected, min.len = 1, any.missing = FALSE),
329	39x	checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
330	39x	checkmate::check_logical(selected, min.len = 1, any.missing = FALSE),
331	39x	checkmate::check_class(selected, "delayed_data"),
332	39x	checkmate::check_class(selected, "all_choices")
333		)
334
335	39x	out <- structure(
336	39x	list(
337	39x	vars_choices = vars_choices,
338	39x	vars_selected = vars_selected,
339	39x	vars_label = vars_label,
340	39x	vars_fixed = vars_fixed,
341	39x	vars_multiple = vars_multiple,
342	39x	choices = choices,
343	39x	selected = selected,
344	39x	label = label,
345	39x	multiple = multiple,
346	39x	fixed = fixed,
347	39x	sep = sep,
348	39x	drop_keys = drop_keys,
349	39x	dataname = dataname, # modified by data_extract_spec,
350	39x	initialized = initialized
351		),
352	39x	class = c(
353	39x	"delayed_filter_spec",
354	39x	"filter_spec",
355	39x	"delayed_data"
356		)
357		)
358	39x	return(out)
359		}
360
361		#' @rdname filter_spec_internal
362		#' @export
363		filter_spec_internal.default <- function(vars_choices,
364		vars_selected = NULL,
365		vars_label = NULL,
366		vars_fixed = FALSE,
367		vars_multiple = TRUE,
368		choices = NULL,
369		selected = NULL,
370		label = NULL,
371		fixed = FALSE,
372		multiple = TRUE,
373		sep = attr(vars_choices, "sep"),
374		drop_keys = FALSE,
375		dataname = NULL,
376		initialized = FALSE) {
377	7x	if (is.null(sep)) sep <- " - "
378	110x	checkmate::assert(
379	110x	checkmate::check_character(vars_choices, min.len = 1, any.missing = FALSE),
380	110x	checkmate::check_numeric(vars_choices, min.len = 1, any.missing = FALSE),
381	110x	checkmate::check_logical(vars_choices, min.len = 1, any.missing = FALSE)
382		)
383	110x	stopifnot(all(!duplicated(vars_choices)))
384
385	110x	if (!is.null(vars_selected)) {
386	109x	stopifnot(vars_multiple \|\| length(vars_selected) == 1)
387	109x	checkmate::assert(
388	109x	checkmate::check_character(vars_selected, min.len = 1, any.missing = FALSE),
389	109x	checkmate::check_numeric(vars_selected, min.len = 1, any.missing = FALSE),
390	109x	checkmate::check_logical(vars_selected, min.len = 1, any.missing = FALSE)
391		)
392	109x	stopifnot(all(!duplicated(vars_selected)))
393	109x	stopifnot(all(vars_selected %in% vars_choices))
394		}
395
396	110x	if (!is.null(choices)) {
397	94x	stopifnot(all(!duplicated(choices)))
398	93x	split_choices <- split_by_sep(choices, sep)
399	93x	stopifnot(all(vapply(split_choices, length, integer(1)) == length(vars_selected)))
400		}
401
402	106x	if (!is.null(selected) && !inherits(selected, "all_choices")) {
403	90x	stopifnot(multiple \|\| length(selected) == 1)
404	89x	checkmate::assert(
405	89x	checkmate::check_character(selected, min.len = 1, any.missing = FALSE),
406	89x	checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
407	89x	checkmate::check_logical(selected, min.len = 1, any.missing = FALSE)
408		)
409	89x	stopifnot(all(!duplicated(selected)))
410	89x	stopifnot(all(selected %in% choices))
411		}
412
413	105x	res <- list(
414	105x	vars_choices = vars_choices,
415	105x	vars_selected = vars_selected,
416	105x	vars_label = vars_label,
417	105x	vars_fixed = vars_fixed,
418	105x	vars_multiple = vars_multiple,
419	105x	choices = choices,
420	105x	selected = selected,
421	105x	label = label,
422	105x	multiple = multiple,
423	105x	fixed = fixed,
424	105x	sep = sep,
425	105x	drop_keys = drop_keys,
426	105x	dataname = dataname, # modified by data_extract_spec
427	105x	initialized = initialized
428		)
429	105x	class(res) <- "filter_spec"
430
431	105x	return(res)
432		}

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

1		#' @title Formatting data extracts
2		#' @description Returns a human-readable string representation of an extracted `data_extract_spec` object.
3		#'
4		#' @details
5		#' This function formats the output of [`data_extract_srv`]. See the example for more information.
6		#'
7		#' @param data_extract `list` the list output of `data_extract_srv`
8		#' @return `character(1)` the string representation
9		#' @examples
10		#' simple_des <- data_extract_spec(
11		#' dataname = "iris",
12		#' filter = filter_spec(vars = "Petal.Length", choices = c("1.4", "1.5")),
13		#' select = select_spec(choices = c("Petal.Length", "Species"))
14		#' )
15		#'
16		#' sample_filtered_data <- {
17		#' teal.slice::init_filtered_data(
18		#' list(iris = list(dataset = iris))
19		#' )
20		#' }
21		#'
22		#' if (interactive()) {
23		#' shiny::shinyApp(
24		#' ui = shiny::fluidPage(
25		#' data_extract_ui(
26		#' id = "extract",
27		#' label = "data extract ui",
28		#' data_extract_spec = simple_des,
29		#' is_single_dataset = TRUE
30		#' ),
31		#' shiny::verbatimTextOutput("formatted_extract")
32		#' ),
33		#' server = function(input, output, session) {
34		#' extracted_input <- data_extract_srv(
35		#' id = "extract",
36		#' datasets = sample_filtered_data,
37		#' data_extract_spec = simple_des
38		#' )
39		#' output$formatted_extract <- shiny::renderPrint({
40		#' cat(format_data_extract(extracted_input()))
41		#' })
42		#' }
43		#' )
44		#' }
45		#' @export
46		#'
47		format_data_extract <- function(data_extract) {
48	19x	if (is.null(data_extract)) {
49	!	return(NULL)
50		}
51
52	19x	checkmate::assert_list(data_extract)
53	19x	required_names <- c("select", "filters", "dataname")
54	19x	if (!checkmate::test_subset(required_names, choices = names(data_extract))) {
55	1x	stop(sprintf("data_extract must be a named list with names: %s", paste0(required_names, collapse = " ")))
56		}
57
58	18x	out <- sprintf("<Data Extract for dataset: %s>", data_extract$dataname)
59	18x	out <- c(out, "Filters:")
60	18x	for (filter in data_extract$filters) {
61	12x	filtering_columns <- paste0(filter$columns, collapse = " ")
62	12x	selected_values <- paste0(filter$selected, collapse = " ")
63	12x	out <- c(out, sprintf(" Columns: %s Selected: %s", filtering_columns, selected_values))
64		}
65
66	18x	out <- c(out, "Selected columns:")
67	18x	selected_columns <- paste0(data_extract$select, collapse = " ")
68	18x	out <- c(out, sprintf(" %s", selected_columns))
69
70	18x	paste0(out, collapse = "\n")
71		}

1		.onLoad <- function(libname, pkgname) { # nolint
2	!	teal.logger::register_logger("teal.transform")
3	!	invisible()
4		}

1		check_merge_function <- function(merge_function) {
2	73x	checkmate::assert_string(merge_function)
3	73x	stopifnot(length(intersect(methods::formalArgs(eval(rlang::parse_expr(merge_function))), c("x", "y", "by"))) == 3)
4		}

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

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

1		#' Returns a `shiny.tag` object with the UI for a `filter_spec` object
2		#'
3		#' @details Creates two `optionSelectInput` elements (one for column and one for values) based
4		#' on a definition of a [filter_spec()] object.
5		#'
6		#' @param filter (`filter_spec`) the object generated with [filter_spec()]
7		#' @param id (`character(1)`) the shiny `inputId` for the generated `shiny.tag`
8		#'
9		#' @return `shiny.tag` defining the `filter_spec`'s UI element
10		#' @keywords internal
11		#' @examples
12		#' teal.transform:::data_extract_filter_ui(filter = filter_spec(vars = "test_var"), id = "test_id")
13		data_extract_filter_ui <- function(filter, id = "filter") {
14	6x	checkmate::assert_class(filter, "filter_spec")
15	6x	checkmate::assert_string(id)
16
17	6x	ns <- NS(id)
18
19	6x	html_col <- teal.widgets::optionalSelectInput(
20	6x	inputId = ns("col"),
21	6x	label = filter$vars_label,
22	6x	choices = filter$vars_choices,
23	6x	selected = filter$vars_selected,
24	6x	multiple = filter$vars_multiple,
25	6x	fixed = filter$vars_fixed
26		)
27
28	6x	html_vals <- teal.widgets::optionalSelectInput(
29	6x	inputId = ns("vals"),
30	6x	label = filter$label,
31	6x	choices = filter$choices,
32	6x	selected = filter$selected,
33	6x	multiple = filter$multiple,
34	6x	fixed = filter$fixed
35		)
36
37	6x	div(
38	6x	class = "filter_spec",
39	6x	if (filter$vars_fixed) shinyjs::hidden(html_col) else html_col,
40	6x	html_vals
41		)
42		}
43
44		#' Handles events emitted from the UI generated by `data_extract_filter_ui`.
45		#'
46		#' @note This shiny module server updates the values of the `vals`
47		#' [teal.widgets::optionalSelectInput()] widget. It's responsible
48		#' for setting the initial values and the subsequent updates to
49		#' the `vals` widget based on the input of the `col` widget.
50		#'
51		#' @param id (`character`) id string
52		#' @param datasets (`named list`) a list of reactive `data.frame` type objects.
53		#' @param filter (`filter_spec`) the filter generated by a call to [filter_spec()]
54		#' @keywords internal
55		data_extract_filter_srv <- function(id, datasets, filter) {
56	8x	checkmate::assert_list(datasets, types = "reactive", names = "named")
57	8x	moduleServer(
58	8x	id,
59	8x	function(input, output, session) {
60		# We force the evaluation of filter, otherwise the observers are set up with the last element
61		# of the list in data_extract_single_srv and not all of them (due to R lazy evaluation)
62	8x	force(filter)
63	8x	logger::log_trace(
64	8x	"data_extract_filter_srv initialized with: { filter$dataname } dataset."
65		)
66
67	8x	observeEvent(input$col,
68	8x	handlerExpr = {
69	6x	if (!filter$initialized) {
70	6x	initial_inputs <- get_initial_filter_values(filter, datasets)
71	6x	choices <- initial_inputs$choices
72	6x	selected <- initial_inputs$selected
73	6x	filter$initialized <- TRUE
74	6x	filter <<- filter
75	!	} else if (!rlang::is_empty(input$col)) {
76	!	choices <- value_choices(
77	!	datasets[[filter$dataname]](),
78	!	input$col,
79	!	`if`(isTRUE(input$col == attr(filter$choices, "var_choices")), attr(filter$choices, "var_label"), NULL)
80		)
81
82	!	selected <- if (!is.null(filter$selected)) {
83	!	filter$selected
84	!	} else if (filter$multiple) {
85	!	choices
86		} else {
87	!	choices[1]
88		}
89		} else {
90	!	choices <- character(0)
91	!	selected <- character(0)
92		}
93	6x	dn <- filter$dataname
94	6x	fc <- paste(input$col, collapse = ", ")
95	6x	logger::log_trace("data_extract_filter_srv@1 filter dataset: { dn }; filter var: { fc }.")
96		# In order to force reactivity we run two updates: (i) set up dummy values (ii) set up appropriate values
97		# It's due to a missing reactivity triggers if new selected value is identical with previously selected one.
98	6x	teal.widgets::updateOptionalSelectInput(
99	6x	session = session,
100	6x	inputId = "vals",
101	6x	choices = paste0(input$val, "$_<-_random_text_to_ensure_val_will_be_different_from_previous"),
102	6x	selected = paste0(input$val, "$_<-_random_text_to_ensure_val_will_be_different_from_previous")
103		)
104
105	6x	teal.widgets::updateOptionalSelectInput(
106	6x	session = session,
107	6x	inputId = "vals",
108	6x	choices = choices,
109	6x	selected = selected
110		)
111		},
112	8x	ignoreInit = FALSE,
113	8x	ignoreNULL = FALSE
114		)
115		}
116		)
117		}
118
119		#' Returns the initial values for the `vals` widget
120		#' of a `filter_spec` object.
121		#'
122		#' @inheritParams data_extract_filter_srv
123		#' @return `named list` with two slots `choices` and `selected`
124		#' @keywords internal
125		#'
126		#' @examples
127		#' filtered_data_list <- list(iris = shiny::reactive(utils::head(iris)))
128		#' filter <- filter_spec(vars = colnames(iris)[1])
129		#' filter$dataname <- "iris"
130		#' shiny::isolate(
131		#' teal.transform:::get_initial_filter_values(filter = filter, datasets = filtered_data_list)
132		#' )
133		#'
134		get_initial_filter_values <- function(filter, datasets) {
135	9x	initial_values <- list()
136	9x	if (is.null(filter$vars_selected)) {
137	2x	initial_values$choices <- character(0)
138	2x	initial_values$selected <- character(0)
139	7x	} else if (is.null(filter$choices)) {
140	1x	initial_values$choices <- value_choices(
141	1x	datasets[[filter$dataname]](),
142	1x	as.character(filter$vars_selected)
143		)
144	1x	initial_values$selected <- if (inherits(filter$selected, "all_choices")) {
145	!	initial_values$choices
146		} else {
147	1x	filter$selected
148		}
149		} else {
150	6x	initial_values$choices <- filter$choices
151	6x	initial_values$selected <- filter$selected
152		}
153
154	9x	initial_values
155		}

1		#' Available datasets input
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' Creates \link[shiny]{helpText} with the names of datasets
5		#' available for current module.
6		#' @param data_extracts list of data extracts for single variable
7		#' @export
8		datanames_input <- function(data_extracts) {
9	!	datanames <- get_extract_datanames(data_extracts)
10	!	helpText(
11	!	paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
12	!	tags$code(paste(datanames, collapse = ", "))
13		)
14		}
15
16		#' Gets names of the datasets from a list of `data_extract_spec` objects
17		#'
18		#' @description `r lifecycle::badge("stable")`
19		#' Fetches `dataname` slot per \code{data_extract_spec} from a list of \code{data_extract_spec}
20		#' and returns the unique `dataname` set.
21		#'
22		#' @param data_extracts A single \code{data_extract_spec} object or a list (of lists) of \code{data_extract_spec}
23		#'
24		#' @export
25		get_extract_datanames <- function(data_extracts) {
26	17x	data_extracts <- if (inherits(data_extracts, "data_extract_spec")) {
27	2x	list(data_extracts)
28		} else {
29	15x	data_extracts
30		}
31	17x	checkmate::assert_list(data_extracts)
32
33	14x	data_extracts <- Filter(Negate(is.null), data_extracts)
34	14x	data_extracts <- Filter(Negate(is.logical), data_extracts)
35	14x	data_extracts <- Filter(Negate(is.choices_selected), data_extracts)
36
37	14x	stopifnot(length(data_extracts) > 0)
38	13x	stopifnot(
39	13x	checkmate::test_list(data_extracts, types = "data_extract_spec") \|\|
40	13x	all(
41	13x	vapply(data_extracts, function(x) checkmate::test_list(x, types = "data_extract_spec"), logical(1))
42		)
43		)
44
45	11x	datanames <- lapply(data_extracts, function(x) {
46	20x	if (inherits(x, "data_extract_spec")) {
47	12x	x[["dataname"]]
48	8x	} else if (checkmate::test_list(x, types = "data_extract_spec")) {
49	8x	lapply(x, `[[`, "dataname")
50		}
51		})
52
53	11x	unique(unlist(datanames))
54		}
55
56		#' Checks if the input `data_extract_spec` objects all come from the same dataset
57		#'
58		#' @description `r lifecycle::badge("stable")`
59		#' @param ... either \code{data_extract_spec} objects or lists of \code{data_extract_spec} objects that do not contain
60		#' NULL
61		#' @return logical
62		#' @export
63		is_single_dataset <- function(...) {
64	!	data_extract_spec <- list(...)
65	!	dataset_names <- get_extract_datanames(data_extract_spec)
66	!	return(length(dataset_names) == 1)
67		}

1		#' Data Extract input for teal modules
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' The Data Extract input can be used to filter and select columns from a data
6		#' set. This function enables such an input in teal.
7		#' Please use the constructor function [data_extract_spec] to set it up.
8		#'
9		#' Note that no checks based on columns can be done because the data is only referred to by name.
10		#'
11		#' @export
12		#' @rdname data_extract_spec
13		#'
14		#' @section Module Development:
15		#' \describe{
16		#' `teal.transform` uses this object to construct a UI element in a module.
17		#' }
18		#'
19		#' @param dataname (`character`)\cr
20		#' The name of the dataset to be extracted.
21		#' @param select (`NULL`, `select_spec`-S3 class or `delayed_select_spec`)\cr
22		#' Columns to be selected from the input dataset
23		#' mentioned in `dataname`. The setup can be created using [select_spec] function.
24		#' @param filter (`NULL` or `filter_spec` or its respective delayed version)\cr
25		#' Setup of the filtering of key columns inside the dataset.
26		#' This setup can be created using the [filter_spec] function.
27		#' Please note that if both select and filter are set to NULL, then the result will be a filter spec UI with all
28		#' variables as possible choices and a select spec with multiple set to `TRUE`.
29		#' @param reshape (`logical`)\cr
30		#' whether reshape long to wide. Note that it will be used only in case of long dataset with multiple
31		#' keys selected in filter part.
32		#'
33		#' @examples
34		#' adtte_filters <- filter_spec(
35		#' vars = c("PARAMCD", "CNSR"),
36		#' sep = "-",
37		#' choices = c("OS-1" = "OS-1", "OS-0" = "OS-0", "PFS-1" = "PFS-1"),
38		#' selected = "OS-1",
39		#' multiple = FALSE,
40		#' label = "Choose endpoint and Censor"
41		#' )
42		#'
43		#' data_extract_spec(
44		#' dataname = "ADTTE",
45		#' filter = adtte_filters,
46		#' select = select_spec(
47		#' choices = c("AVAL", "BMRKR1", "AGE"),
48		#' selected = c("AVAL", "BMRKR1"),
49		#' multiple = TRUE,
50		#' fixed = FALSE,
51		#' label = "Column"
52		#' )
53		#' )
54		#'
55		#' data_extract_spec(
56		#' dataname = "ADSL",
57		#' filter = NULL,
58		#' select = select_spec(
59		#' choices = c("AGE", "SEX", "USUBJID"),
60		#' selected = c("SEX"),
61		#' multiple = FALSE,
62		#' fixed = FALSE
63		#' )
64		#' )
65		#' data_extract_spec(
66		#' dataname = "ADSL",
67		#' filter = filter_spec(
68		#' vars = variable_choices("ADSL", subset = c("AGE"))
69		#' )
70		#' )
71		#'
72		#' dynamic_filter <- filter_spec(
73		#' vars = choices_selected(variable_choices("ADSL"), "COUNTRY"),
74		#' multiple = TRUE
75		#' )
76		#' data_extract_spec(
77		#' dataname = "ADSL",
78		#' filter = dynamic_filter
79		#' )
80		#'
81		#' @references [select_spec] [filter_spec]
82		data_extract_spec <- function(dataname, select = NULL, filter = NULL, reshape = FALSE) {
83	129x	checkmate::assert_string(dataname)
84	129x	stopifnot(
85	129x	is.null(select) \|\|
86	129x	(inherits(select, "select_spec") && length(select) >= 1)
87		)
88	128x	checkmate::assert(
89	128x	checkmate::check_null(filter),
90	128x	checkmate::check_class(filter, "filter_spec"),
91	128x	checkmate::check_list(filter, "filter_spec")
92		)
93	128x	checkmate::assert_flag(reshape)
94
95	128x	if (is.null(select) && is.null(filter)) {
96	6x	select <- select_spec(
97	6x	choices = variable_choices(dataname),
98	6x	multiple = TRUE
99		)
100	6x	filter <- filter_spec(
101	6x	vars = choices_selected(variable_choices(dataname)),
102	6x	selected = all_choices()
103		)
104		}
105
106	55x	if (inherits(filter, "filter_spec")) filter <- list(filter)
107
108	115x	for (idx in seq_along(filter)) filter[[idx]]$dataname <- dataname
109
110	128x	if (inherits(select, "delayed_select_spec") \|\|
111	128x	any(vapply(filter, inherits, logical(1), "delayed_filter_spec"))) {
112	40x	structure(
113	40x	list(dataname = dataname, select = select, filter = filter, reshape = reshape),
114	40x	class = c("delayed_data_extract_spec", "delayed_data", "data_extract_spec")
115		)
116		} else {
117	88x	structure(
118	88x	list(dataname = dataname, select = select, filter = filter, reshape = reshape),
119	88x	class = "data_extract_spec"
120		)
121		}
122		}

1		# Contains modules to check the input provided to the `tm_*` functions is correct.
2		# In general, they are checking functions, in the sense that they call `stopifnot`
3		# if the conditions are not met.
4
5		#' Make sure that the extract spec has list form
6		#'
7		#' @md
8		#' @description `r lifecycle::badge("stable")`
9		#'
10		#' @param x `data_extract_spec` a single `data_extract_spec` or list of these
11		#' @param allow_null `logical` whether x can be `NULL`
12		#'
13		#' @return x as a list if it is not already
14		#'
15		#' @export
16		list_extract_spec <- function(x, allow_null = FALSE) {
17	6x	if (is.null(x)) {
18	!	stopifnot(allow_null)
19	!	return(NULL)
20		}
21	6x	if (!checkmate::test_list(x, types = "data_extract_spec")) {
22	5x	x <- list(x)
23		}
24	6x	stopifnot(checkmate::test_list(x, types = "data_extract_spec"))
25	6x	x
26		}
27
28		#' Checks that the extract_input specification does not allow multiple
29		#' selection
30		#'
31		#' @md
32		#' @description `r lifecycle::badge("stable")`
33		#'
34		#' @param extract_input `data_extract_spec` a list of `data_extract_spec` or NULL
35		#'
36		#' Stops if condition not met
37		#'
38		#' @export
39		check_no_multiple_selection <- function(extract_input) {
40		# bug in is_class_list when NULL
41	3x	checkmate::assert_list(extract_input, types = "data_extract_spec", null.ok = TRUE)
42	2x	all(vapply(extract_input, function(elem) !isTRUE(elem$select$multiple), logical(1))) \|\|
43	2x	stop("extract_input variable should not allow multiple selection")
44	1x	invisible(NULL)
45		}

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

1		#' Resolve delayed inputs by evaluating the code within the provided datasets
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' @param x (`delayed_data`, `list`) to resolve.
6		#' @param datasets (`FilteredData` or named `list`) to use as a reference to resolve `x`.
7		#' @param keys (named `list`) with primary keys for each dataset from `datasets`. `names(keys)`
8		#' should match `names(datasets)`
9		#'
10		#' @return Resolved object.
11		#'
12		#' @export
13		#'
14		#' @examples
15		#' ADSL <- teal.transform::rADSL
16		#' shiny::isolate({
17		#' ds <- teal.slice::init_filtered_data(
18		#' list(ADSL = list(dataset = ADSL))
19		#' )
20		#'
21		#' # value_choices example
22		#' v1 <- value_choices("ADSL", "SEX", "SEX")
23		#' v1
24		#' resolve_delayed(v1, ds)
25		#'
26		#' # variable_choices example
27		#' v2 <- variable_choices("ADSL", c("BMRKR1", "BMRKR2"))
28		#' v2
29		#' resolve_delayed(v2, ds)
30		#'
31		#' # data_extract_spec example
32		#' adsl_filter <- filter_spec(
33		#' vars = variable_choices("ADSL", "SEX"),
34		#' sep = "-",
35		#' choices = value_choices("ADSL", "SEX", "SEX"),
36		#' selected = "F",
37		#' multiple = FALSE,
38		#' label = "Choose endpoint and Censor"
39		#' )
40		#'
41		#' adsl_select <- select_spec(
42		#' label = "Select variable:",
43		#' choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
44		#' selected = "BMRKR1",
45		#' multiple = FALSE,
46		#' fixed = FALSE
47		#' )
48		#'
49		#' adsl_de <- data_extract_spec(
50		#' dataname = "ADSL",
51		#' select = adsl_select,
52		#' filter = adsl_filter
53		#' )
54		#'
55		#' resolve_delayed(adsl_filter, ds)
56		#' resolve_delayed(adsl_select, ds)
57		#' resolve_delayed(adsl_de, ds)
58		#'
59		#' # nested list (arm_ref_comp)
60		#' arm_ref_comp <- list(
61		#' ARMCD = list(
62		#' ref = variable_choices("ADSL"),
63		#' comp = variable_choices("ADSL")
64		#' )
65		#' )
66		#'
67		#' resolve_delayed(arm_ref_comp, ds)
68		#' })
69		resolve_delayed <- function(x, datasets, keys) {
70	38x	UseMethod("resolve_delayed", datasets)
71		}
72
73
74		#' @export
75		resolve_delayed.FilteredData <- function(x,
76		datasets,
77		keys = sapply(datasets$datanames(), datasets$get_keys, simplify = FALSE)) {
78	36x	datasets_list <- sapply(X = datasets$datanames(), simplify = FALSE, FUN = function(x) {
79	64x	reactive(datasets$get_data(dataname = x, filtered = TRUE))
80		})
81	36x	resolve(x, datasets_list, keys)
82		}
83
84		#' @export
85		resolve_delayed.list <- function(x, datasets, keys = NULL) {
86	2x	checkmate::assert_list(datasets, type = c("reactive", "data.frame"), min.len = 1, names = "named")
87	2x	checkmate::assert_list(keys, "character", names = "named", null.ok = TRUE)
88	2x	checkmate::assert(
89	2x	.var.name = "keys",
90	2x	checkmate::check_names(names(keys), subset.of = names(datasets)),
91	2x	checkmate::check_null(keys)
92		)
93		# convert to list of reactives
94	2x	datasets_list <- sapply(X = datasets, simplify = FALSE, FUN = function(x) {
95	1x	if (is.reactive(x)) x else reactive(x)
96		})
97	2x	resolve(x, datasets_list, keys)
98		}

1		#' An S3 structure representing the selection of all
2		#' possible choices in a `filter_spec`, `select_spec` or `choices_selected` object.
3		#'
4		#' @description `r lifecycle::badge("experimental")`
5		#'
6		#' @return `all_choices` object
7		#'
8		#' @examples
9		#' # Both structures are semantically identical
10		#' filter_spec(
11		#' vars = c("selected_variable"),
12		#' choices = c("value1", "value2"),
13		#' selected = c("value1", "value2")
14		#' )
15		#'
16		#' filter_spec(
17		#' vars = c("selected_variable"),
18		#' choices = c("value1", "value2"),
19		#' selected = all_choices()
20		#' )
21		#'
22		#' choices_selected(choices = letters, selected = letters)
23		#' choices_selected(choices = letters, selected = all_choices())
24		#' @export
25		all_choices <- function() {
26	12x	structure(list(), class = "all_choices")
27		}

1		#' Returns a `shiny.tag.list` object with the UI for a `select_spec` object
2		#'
3		#' @param select (`select_spec`) A definition of a select spec element.
4		#' Setting [select_spec()] with `ordered = TRUE` makes this selector responsive to the variable
5		#' selection order.
6		#' @param id (`character(1)`) The shiny `inputId` of the element
7		#' @return `shiny.tag.list` with the UI
8		#' @keywords internal
9		#' @examples
10		#' teal.transform:::data_extract_select_ui(
11		#' select = select_spec(choices = "test_choice"),
12		#' id = "test_id"
13		#' )
14		data_extract_select_ui <- function(select, id = "select") {
15	4x	checkmate::assert_class(select, "select_spec")
16	4x	checkmate::assert_string(id)
17
18		## select input
19	4x	res <- list(
20	4x	teal.widgets::optionalSelectInput(
21	4x	inputId = id,
22	4x	label = select$label,
23	4x	choices = select$choices,
24	4x	selected = select$selected,
25	4x	multiple = select$multiple,
26	4x	fixed = select$fixed
27		)
28		)
29
30	4x	if (!is.null(select$always_selected)) {
31	!	res <- append(
32	!	res,
33	!	list(
34	!	shinyjs::hidden(
35	!	selectInput(
36	!	inputId = paste0(id, "_additional"),
37	!	label = "",
38	!	choices = select$always_selected,
39	!	selected = select$always_selected,
40	!	multiple = length(select$always_selected) > 1
41		)
42		),
43	!	helpText(
44	!	"Default Column(s)",
45	!	tags$code(paste(select$always_selected, collapse = " "))
46		)
47		)
48		)
49		}
50
51	4x	do.call("tagList", res)
52		}

1		#' Data merge module
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#' @details This function was a convenient wrapper to combine `data_extract_multiple_srv()` and
5		#' `data_merge_srv()` when no additional processing is required.
6		#'
7		#' @inheritParams shiny::moduleServer
8		#' @param datasets (`FilteredData`)\cr
9		#' object containing data, see [teal.slice::FilteredData] for more.
10		#' @param data_extract (named `list` of `data_extract_spec`)\cr
11		#' @param merge_function (`character(1)`)\cr
12		#' A character string of a function that
13		#' accepts the arguments `x`, `y` and `by` to perform the merging of datasets.
14		#' @param anl_name (`character(1)`)\cr
15		#' Name of the analysis dataset.
16		#'
17		#' @return reactive expression with output from [data_merge_srv()].
18		#'
19		#' @seealso [data_merge_srv()]
20		#'
21		#' @export
22		data_merge_module <- function(datasets,
23		data_extract,
24		merge_function = "dplyr::full_join",
25		anl_name = "ANL",
26		id = "merge_id") {
27	!	lifecycle::deprecate_stop("0.3.1", "data_merge_module()")
28		}
29
30
31		#' Data merge module server
32		#'
33		#' @description `r lifecycle::badge("deprecated")`
34		#' @details When additional processing of the `data_extract` list input was required, `data_merge_srv()` could be
35		#' combined with `data_extract_multiple_srv()` or `data_extract_srv()` to influence the `selector_list` input.
36		#'
37		#' @inheritParams shiny::moduleServer
38		#' @param selector_list (`reactive`)\cr
39		#' output from [data_extract_multiple_srv()] or a reactive named list of outputs from [data_extract_srv()].
40		#' When using a reactive named list, the names must be identical to the shiny ids of the
41		#' respective [data_extract_ui()].
42		#' @param datasets (`FilteredData`)\cr
43		#' object containing data (see `teal.slice::FilteredData`).
44		#' @param merge_function (`character(1)` or `reactive`)\cr
45		#' A character string of a function that accepts the arguments
46		#' `x`, `y` and `by` to perform the merging of datasets.
47		#' @param anl_name (`character(1)`)\cr
48		#' Name of the analysis dataset.
49		#'
50		#' @return reactive expression with output from [merge_datasets].
51		#'
52		#' @seealso [data_extract_srv()]
53		#'
54		#' @export
55		data_merge_srv <- function(id = "merge_id",
56		selector_list,
57		datasets,
58		merge_function = "dplyr::full_join",
59		anl_name = "ANL") {
60	!	lifecycle::deprecate_stop("0.3.1", "data_merge_srv()")
61		}