teal.transform coverage - 81.18%

Files
Source

#' Returns a `shiny.tag` with the UI elements for a `data_extract_spec`
#'
#' @details
#' Creates a `shiny.tag` element defining the UI elements corresponding to 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
#'
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(
    tags$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
  tags$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_debug("data_extract_single_srv initialized with dataset: { single_data_extract_spec$dataname }.")

      # ui could be initialized with a delayed select spec so the choices and selected are NULL
      # here delayed are resolved
      isolate({
        resolved <- resolve_delayed(single_data_extract_spec, datasets)
        teal.widgets::updateOptionalSelectInput(
          session = session,
          inputId = "select",
          choices = resolved$select$choices,
          selected = resolved$select$selected
        )
      })

      for (idx in seq_along(resolved$filter)) {
        x <- resolved$filter[[idx]]
        if (inherits(x, "filter_spec")) {
          data_extract_filter_srv(
            id = paste0("filter", idx),
            datasets = datasets,
            filter = x
          )
        }
        NULL
      }
    }
  )
}

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

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

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

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

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

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

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

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

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

  UseMethod("variable_choices")
}

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

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

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

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

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

  key <- intersect(subset, key)

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

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

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

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

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

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

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

  var_choices <- as.vector(var_choices)
  df_choices <- data[var_choices]
  df_label <- data[var_label]

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

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

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

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

  invisible(x)
}

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

  UseMethod("resolve")
}

#' @describeIn resolve Call [variable_choices()] on the delayed `variable_choices` object.
#' @export
resolve.delayed_variable_choices <- function(x, datasets, keys) {
  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)
  }

  do.call("variable_choices", x)
}

#' @describeIn resolve Call [value_choices()] on the delayed `value_choices` object.
#' @export
resolve.delayed_value_choices <- function(x, datasets, keys) {
  x$data <- datasets[[x$data]]()
  if (inherits(x$var_choices, "delayed_variable_choices")) {
    x$var_choices <- resolve(x$var_choices, datasets, keys)
  }
  if (is.function(x$subset)) {
    x$subset <- resolve_delayed_expr(x$subset, ds = x$data, is_value_choices = TRUE)
  }

  do.call("value_choices", x)
}

#' @describeIn resolve Call [select_spec()] on the delayed `choices_selected` object.
#' @export
resolve.delayed_choices_selected <- function(x, datasets, keys) {
  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)) {
    warning(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)]
  }

  do.call("choices_selected", x)
}

#' @describeIn resolve Call [select_spec()] on the delayed specification.
#' @export
resolve.delayed_select_spec <- function(x, datasets, keys) {
  x$choices <- resolve(x$choices, datasets = datasets, keys)
  if (inherits(x$selected, "delayed_data")) {
    x$selected <- resolve(x$selected, datasets = datasets, keys)
  }

  do.call("select_spec", x)
}

#' @describeIn resolve Call [filter_spec()] on the delayed specification.
#' @export
resolve.delayed_filter_spec <- function(x, datasets, keys) {
  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)
  }

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

#' @describeIn resolve Call [data_extract_spec()] on the delayed specification.
#' @export
resolve.delayed_data_extract_spec <- function(x, datasets, keys) {
  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)
  }

  do.call("data_extract_spec", x)
}

#' @describeIn resolve Iterates over elements of the list and recursively calls
#' `resolve`.
#' @export
resolve.list <- function(x, datasets, keys) {
  # If specified explicitly, return it unchanged. Otherwise if delayed, resolve.
  lapply(x, resolve, datasets = datasets, keys = keys)
}

#' @describeIn resolve Default method that does nothing and returns `x` itself.
#' @export
resolve.default <- function(x, datasets, keys) {
  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`) Dataset.
#' @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
#'
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 (!checkmate::test_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")
      ))
    }
  }

  res
}

#' @export
#' @keywords internal
#'
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)

  invisible(NULL)
}

#' @export
#' @keywords internal
#'
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)

  invisible(NULL)
}

#' @export
#' @keywords internal
#'
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)

  invisible(NULL)
}

#' @export
#' @keywords internal
#'
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)

  invisible(NULL)
}

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

  invisible(NULL)
}

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

  invisible(NULL)
}

#' @export
#' @keywords internal
#'
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)

  invisible(NULL)
}

#' Create indented message
#' @keywords internal
#' @noRd
#'
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 = "")

  paste0(indent, msg)
}

#' Common function to print a `delayed_data` object
#' @keywords internal
#' @noRd
#'
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")
    }
  }

  invisible(NULL)
}

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

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

  dplyr_call_data <- get_dplyr_call_data(merged_selector_list, join_keys)

  validate_keys_sufficient(join_keys, merged_selector_list)

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

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

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

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

  all_calls_expression <- c(dplyr_calls, anl_merge_calls, anl_relabel_call)

  # Ensure dplyr is loaded if any of the generated calls use the pipe operator
  if (call_uses_magrittr_pipe(all_calls_expression)) {
    library_dplyr_call <- call("library", as.name("magrittr"))
    all_calls_expression <- c(list(library_dplyr_call), all_calls_expression)
  }

  # 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_debug("merge_datasets merge code executed resulting in { anl_name } dataset.")
  res
}

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

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

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


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

  list(res_list, res_map_id)
}


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

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

  TRUE
}

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

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

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

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

  all(datasets_pairs_keys_present)
}

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

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

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

#' @keywords internal
#' @noRd
data_extract_deps <- function() {
  htmltools::htmlDependency(
    name = "teal-widgets-data-extract",
    version = utils::packageVersion("teal.transform"),
    package = "teal.transform",
    src = "css",
    stylesheet = "data-extract.css"
  )
}

#' `teal` data extraction module user-interface
#'
#' @description Data extraction module.
#'
#' @details
#' There are three inputs that will be rendered
#'
#' 1. Dataset select Optional. If more than one [data_extract_spec] is handed over
#' to the function, a shiny [shiny::selectInput] will be rendered. Else just the name
#' of the dataset is given.
#' 2. Filter Panel Optional. If the [data_extract_spec] contains a
#' filter element a shiny [shiny::selectInput] will be rendered with the options to
#' filter the dataset.
#' 3. Select panel A shiny [shiny::selectInput] to select columns from the dataset to
#' go into the analysis.
#'
#' The output can be analyzed using `data_extract_srv(...)`.
#'
#' This functionality should be used in the encoding panel of your `teal` app.
#' It will allow app-developers to specify a [data_extract_spec()] object.
#' This object should be used to `teal` module variables being filtered data
#' from CDISC datasets.
#'
#' You can use this function in the same way as any
#' [`shiny module`](https://shiny.rstudio.com/articles/modules.html) UI.
#' The corresponding server module can be found in [data_extract_srv()].
#'
#' @param id (`character`) shiny input unique identifier.
#' @param label (`character`) Label above the data extract input.
#' @param data_extract_spec (`list` of `data_extract_spec`)
#' This is the outcome of listing [data_extract_spec()] constructor calls.
#' @param is_single_dataset (`logical`) `FALSE` to display the dataset widget.
#'
#' @return Shiny [`shiny::selectInput`]`s` that allow to define how to extract data from
#' a specific dataset. The input elements will be returned inside a [shiny::div] container.
#'
#' @examples
#' library(shiny)
#' library(teal.widgets)
#'
#' adtte_filters <- filter_spec(
#'   vars = c("PARAMCD", "CNSR"),
#'   sep = "-",
#'   choices = c("OS-1" = "OS-1", "OS-0" = "OS-0", "PFS-1" = "PFS-1"),
#'   selected = "OS-1",
#'   multiple = FALSE,
#'   label = "Choose endpoint and Censor"
#' )
#'
#' response_spec <- data_extract_spec(
#'   dataname = "ADTTE",
#'   filter = adtte_filters,
#'   select = select_spec(
#'     choices = c("AVAL", "BMRKR1", "AGE"),
#'     selected = c("AVAL", "BMRKR1"),
#'     multiple = TRUE,
#'     fixed = FALSE,
#'     label = "Column"
#'   )
#' )
#' # Call to use inside your teal module UI function
#' bslib::layout_sidebar(
#'   tableOutput("table"),
#'   sidebar = tags$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
      )
    }
  }
  tags$div(
    data_extract_deps(),
    tags$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
#'
#' Extracting details of the selection(s) in [data_extract_ui] elements.
#'
#' @inheritParams shiny::moduleServer
#' @param datasets (`FilteredData` or `list` of `reactive` or non-`reactive` `data.frame`)
#' object containing data either in the form of `FilteredData` or as a list of `data.frame`.
#' When passing a list of non-reactive `data.frame` objects, they are converted to reactive `data.frame`s internally.
#' When passing a list of reactive or non-reactive `data.frame` objects, the argument `join_keys` is required also.
#' @param data_extract_spec (`data_extract_spec` or a list of `data_extract_spec`)
#' A list of data filter and select information constructed by [data_extract_spec].
#' @param ... An additional argument `join_keys` is required when `datasets` is a list of `data.frame`.
#' It shall contain the keys per dataset in `datasets`.
#'
#' @return A reactive `list` containing following fields:
#'
#' * `filters`: A list with the information on the filters that are applied to the data set.
#' * `select`: The variables that are selected from the dataset.
#' * `always_selected`: The column names from the data set that should always be selected.
#' * `reshape`: Whether reshape long to wide should be applied or not.
#' * `dataname`: The name of the data set.
#' * `internal_id`: The `id` of the corresponding shiny input element.
#' * `keys`: The names of the columns that can be used to merge the data set.
#' * `iv`: A `shinyvalidate::InputValidator` containing `validator` for this `data_extract`.
#'
#' @references [data_extract_srv]
#'
#' @examples
#' library(shiny)
#' library(shinyvalidate)
#' library(teal.data)
#' library(teal.widgets)
#'
#' # Sample ADSL dataset
#' ADSL <- data.frame(
#'   STUDYID = "A",
#'   USUBJID = LETTERS[1:10],
#'   SEX = rep(c("F", "M"), 5),
#'   AGE = rpois(10, 30),
#'   BMRKR1 = rlnorm(10)
#' )
#'
#' # Specification for data extraction
#' adsl_extract <- data_extract_spec(
#'   dataname = "ADSL",
#'   filter = filter_spec(vars = "SEX", choices = c("F", "M"), selected = "F"),
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = variable_choices(ADSL, c("AGE", "BMRKR1")),
#'     selected = "AGE",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#'
#' # Using reactive list of data.frames
#' data_list <- list(ADSL = reactive(ADSL))
#'
#' join_keys <- join_keys(join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")))
#'
#' # App: data extraction with validation
#' ui <- bslib::page_fluid(
#'   bslib::layout_sidebar(
#'     verbatimTextOutput("out1"),
#'     encoding = tagList(
#'       data_extract_ui(
#'         id = "adsl_var",
#'         label = "ADSL selection",
#'         data_extract_spec = adsl_extract
#'       )
#'     )
#'   )
#' )
#' server <- function(input, output, session) {
#'   adsl_reactive_input <- data_extract_srv(
#'     id = "adsl_var",
#'     datasets = data_list,
#'     data_extract_spec = adsl_extract,
#'     join_keys = join_keys,
#'     select_validation_rule = sv_required("Please select a variable.")
#'   )
#'
#'   iv_r <- reactive({
#'     iv <- InputValidator$new()
#'     iv$add_validator(adsl_reactive_input()$iv)
#'     iv$enable()
#'     iv
#'   })
#'
#'   output$out1 <- renderPrint({
#'     if (iv_r()$is_valid()) {
#'       cat(format_data_extract(adsl_reactive_input()))
#'     } else {
#'       "Please fix errors in your selection"
#'     }
#'   })
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' # App: simplified data extraction
#' ui <- bslib::page_fluid(
#'   bslib::layout_sidebar(
#'     verbatimTextOutput("out1"),
#'     sidebar = tagList(
#'       data_extract_ui(
#'         id = "adsl_var",
#'         label = "ADSL selection",
#'         data_extract_spec = adsl_extract
#'       )
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   adsl_reactive_input <- data_extract_srv(
#'     id = "adsl_var",
#'     datasets = data_list,
#'     data_extract_spec = adsl_extract
#'   )
#'
#'   output$out1 <- renderPrint(adsl_reactive_input())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
data_extract_srv <- function(id, datasets, data_extract_spec, ...) {
  checkmate::assert_multi_class(datasets, c("FilteredData", "list"))
  checkmate::assert(
    checkmate::check_class(data_extract_spec, "data_extract_spec"),
    checkmate::check_list(data_extract_spec, "data_extract_spec")
  )
  UseMethod("data_extract_srv", datasets)
}

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

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

      join_keys <- datasets$get_join_keys()

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  logger::log_debug(
    "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]]
        )
      }
    )
  })
}

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

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

      merge_keys_list <- all_merge_key_list[[idx]]

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

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

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

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

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

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

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

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

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

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

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

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

  n_selectors <- length(selector_list)

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

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

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

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

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

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

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

  select <- unique(select)

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

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

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

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

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

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

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

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

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

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


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

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

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

  lapply(selector_list, check_selector)

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

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

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

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

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

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

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

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

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

  c(pivot_longer_call, unite_call, pivot_wider_call)
}


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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

    anl_merge_calls <- append(
      anl_merge_calls,
      anl_merge_call_i
    )
  }

  anl_merge_calls
}

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

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

#' Gets keys vector from keys list
#'
#' @details
#' This function covers up to now 4 cases:
#'
#' * Dataset without parent: Primary keys are returned;
#' * Dataset source = dataset target:
#' The primary keys subtracted of all key columns that get purely filtered.
#' This means just one value would be left after filtering inside this column
#' Then it can be taken out;
#' * Target `dataname` is parent foreign keys;
#' * Any other case foreign keys;
#'
#' @param selector_from (`list`) of `data_extract_srv` objects.
#' @param selector_to (`list`) of `data_extract_srv` objects.
#' @param key_from (`character`) keys used in the first selector while joining.
#'
#' @return `character` vector of selector keys.
#'
#' @keywords internal
#'
get_merge_key_pair <- function(selector_from, selector_to, key_from) {
  logger::log_debug(
    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_debug("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 (`integer`) optional, current selector index in all selectors list.
#'
#' @return `character` list of keys.
#'
#' @keywords internal
#'
get_merge_key_i <- function(selector_list, idx, dplyr_call_data = get_dplyr_call_data(selector_list)) {
  checkmate::assert_integer(idx, len = 1, any.missing = FALSE, lower = 2L)

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

    logger::log_debug(
      paste(
        "get_merge_key_i called with:",
        "{ paste(names(selector_list), collapse = ', ') } selectors;",
        "idx = { idx }."
      )
    )
  } else {
    logger::log_debug(
      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_debug("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 (`integer`) optional, current selector index in all selectors list.
#'
#' @return `call` with merge keys.
#'
#' @keywords internal
#'
parse_merge_key_i <- function(selector_list,
                              idx,
                              dplyr_call_data = get_dplyr_call_data(selector_list),
                              merge_key = get_merge_key_i(selector_list, idx, dplyr_call_data)) {
  logger::log_debug("parse_merge_key_i called with { paste(merge_key, collapse = ' ') } keys.")
  as.call(
    append(
      quote(c),
      unlist(merge_key)
    )
  )
}

#' Names of filtered-out filters dropped from selection
#'
#' @details
#' Names of filtered-out filters dropped from automatic selection
#' (key vars are automatically included in select).
#' Dropped filter is filter which became not unique for all observations.
#' This means that if variable is filtered to just one level,
#' it's not a key anymore.
#'
#' Other variables used in filter should also be dropped from automatic
#' selection, unless they have been selected.
#'
#' @inheritParams get_pivot_longer_col
#'
#' @return Vector of `character` names of the filters which should be dropped from select call.
#'
#' @keywords internal
#'
get_dropped_filters <- function(selector) {
  logger::log_debug("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
#'
#' @inheritParams merge_datasets
#' @param columns_source (named `list`)
#' where names are column names, values are labels + additional attribute `dataname`
#'
#' @return (`call`) to relabel `dataset` and assign to `anl_name`.
#'
#' @export
get_anl_relabel_call <- function(columns_source, datasets, anl_name = "ANL") {
  logger::log_debug(
    paste(
      "get_anl_relabel_call called with:",
      "{ paste(names(columns_source), collapse = ', ') } columns_source;",
      "{ anl_name } merged dataset."
    )
  )
  checkmate::assert_string(anl_name)
  stopifnot(attr(regexec("[A-Za-z0-9\\_]*", anl_name)[[1]], "match.length") == nchar(anl_name))
  labels_vector <- Reduce(
    function(x, y) append(x, y),
    lapply(
      columns_source,
      function(selector) {
        column_names <- names(selector)
        if (rlang::is_empty(column_names)) {
          return(NULL)
        }

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

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

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

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

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

  relabel_and_assign_call
}

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

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

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

no_select_keyword <- "-- no selection --"

#' Choices selected
#'
#' @description
#'
#' Construct a single list containing available choices, the default selected value, and
#' additional settings such as to order the choices with the selected elements appearing first
#' or whether to block the user from making selections.
#'
#' Can be used in UI input elements such as [teal.widgets::optionalSelectInput()].
#'
#' @details
#' Please note that the order of selected will always follow the order of choices. The `keep_order`
#' argument is set to false which will run the following code inside:
#'
#' ```
#' choices <- c(selected, setdiff(choices, selected))
#' ```
#'
#' In case you want to keep your specific order of choices, set `keep_order` to `TRUE`.
#'
#' @param choices (`character`) vector of possible choices or `delayed_data` object.
#'
#' See [variable_choices()] and [value_choices()].
#' @param selected (`character`) vector of preselected options, (`delayed_choices`) object
#' or (`delayed_data`) object.
#'
#' If `delayed_data` object then `choices` must also be `delayed_data` object.
#' If not supplied it will default to the first element of `choices` if
#' `choices` is a vector, or `NULL` if `choices` is a `delayed_data` object.
#' @param keep_order (`logical`) In case of `FALSE` the selected variables will
#' be on top of the drop-down field.
#' @param fixed (`logical`) optional, whether to block user to select choices.
#'
#' @return `choices_selected` returns list of `choices_selected`, encapsulating the specified
#' `choices`, `selected`, `keep_order` and `fixed`.
#'
#' @examples
#' library(shiny)
#' library(teal.widgets)
#'
#' ADSL <- teal.data::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"))
#' )
#'
#' # Passing `delayed_choices` object - semantically identical objects:
#' choices_selected(choices = letters, selected = letters)
#' choices_selected(choices = letters, selected = all_choices())
#'
#' choices_selected(
#'   choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])),
#'   selected = "E"
#' )
#' choices_selected(
#'   choices = setNames(LETTERS[1:5], paste("Letter", LETTERS[1:5])),
#'   selected = last_choice()
#' )
#'
#' # functional form (subsetting for factor variables only) of choices_selected
#' # with delayed data loading
#' choices_selected(variable_choices("ADSL", subset = function(data) {
#'   idx <- vapply(data, is.factor, logical(1))
#'   names(data)[idx]
#' }))
#'
#' cs <- choices_selected(
#'   choices = c("A", "B", "C"),
#'   selected = "A"
#' )
#'
#' ui <- bslib::page_fluid(
#'   optionalSelectInput(
#'     inputId = "id",
#'     choices = cs$choices,
#'     selected = cs$selected
#'   )
#' )
#'
#' server <- function(input, output, session) {}
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
choices_selected <- function(choices,
                             selected = if (inherits(choices, "delayed_data")) NULL else choices[1],
                             keep_order = FALSE,
                             fixed = FALSE) {
  checkmate::assert(
    checkmate::check_atomic(choices),
    checkmate::check_class(choices, "delayed_data")
  )
  checkmate::assert(
    checkmate::check_atomic(selected),
    checkmate::check_multi_class(selected, c("delayed_data", "delayed_choices"))
  )
  checkmate::assert_flag(keep_order)
  checkmate::assert_flag(fixed)

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

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

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

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

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

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

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

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

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

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

    x
  }
}

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

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

  vec_attrs <- attributes(vec)

  vec <- vec[idx]

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

  attributes(vec) <- vec_attrs
  vec
}

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

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

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

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

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

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

  idx <- which(duplicated(vec))

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

#' Data extract filter specification
#'
#' @description
#'
#' It consists in choices and additionally the variable names for the choices.
#'
#' @details
#' The `filter_spec` is used inside `teal` apps to allow filtering datasets
#' for their key variables. Imagine having an adverse events table. It has
#' the columns `PARAMCD` and `CNSR`. `PARAMCD` contains the levels
#' `"OS"`, `"PFS"`, `"EFS"`. `CNSR` contains the levels `"0"` and `"1"`.
#' The first example should show how a `filter_spec` setup will influence
#' the drop-down menu the app user will see.
#'
#' @inheritParams select_spec
#' @param vars (`character` or `delayed_data`) object.
#' Character vector giving the columns to be filtered. These should be
#' key variables of the data set to be filtered.
#' `delayed_data` objects can be created via [variable_choices()], [value_choices()],
#' or [choices_selected()].
#' @param sep (`character`) A separator string to split the `choices` or
#' `selected` inputs into the values of the different columns.
#' @param choices (`character` or `numeric` or `logical` or (`delayed_data`) object.
#' Named character vector to define the choices of a shiny [shiny::selectInput()].
#' These choices will be used to filter the dataset.
#'
#' These shall be filter values of the `vars` input separated by the separator(`sep`). Please
#' watch out that the filter values have to follow the order of the `vars` input. In the following
#' example we will show how to filter two columns:
#'
#' `vars = c("PARAMCD","AVISIT")` and `choices = c("CRP - BASELINE", "ALT - BASELINE")`
#' will lead to a filtering of
#' `(PARAMCD == "CRP" & AVISIT == "BASELINE") | (PARAMCD == "ALT" & AVISIT == "BASELINE")`.
#'
#' The `sep` input has to be `" - "` in this case.
#'
#' `delayed_data` objects can be created via [variable_choices()] or [value_choices()].
#' @param selected (`character` or `numeric` or `logical` or (`delayed_data` or `delayed_choices`) object.
#' Named character vector to define the selected values of a shiny [shiny::selectInput()]
#' (default values).
#' This value will be displayed inside the shiny app upon start.
#' `delayed_choices` objects resolve selection when choices become available.
#' @param drop_keys (`logical`) optional, whether to drop filter column from the
#' dataset keys, `TRUE` on default.
#' @param label (`character`) optional, defines a label on top of this specific
#' shiny [shiny::selectInput()]. The default value is `"Filter by"`.
#'
#' @return `filter_spec`-S3-class object or `delayed_filter_spec`-S3-class object.
#'
#' @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()
#' )
#' @export
#'
filter_spec <- function(vars,
                        choices = NULL,
                        selected = `if`(inherits(choices, "delayed_data"), NULL, choices[1]),
                        multiple = length(selected) > 1 || inherits(selected, "multiple_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, "delayed_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, "multiple_choices"))

  if (inherits(selected, "delayed_choices") && !is.null(choices)) selected <- 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
#'
#' Builds a configuration for the `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`)
#' the vector of dataset column names available to build dynamic filter
#' `delayed_data` objects can be created via [variable_choices()].
#' @param vars_selected (`NULL` or named `character`)
#' the selected column name out from `choices`.
#' @param vars_label (`character`)
#' the title printed on the UI element generated on the basis of this `filter_spec`.
#' @param vars_fixed (`logical`)
#' if true allow to change the selected variables in the UI element; otherwise, do not allow.
#' @param vars_multiple (`logical`)
#' if true allow to select multiple variables in the UI elements; otherwise, do not allow.
#' @param fixed (`logical`)
#' if true allow to change the initially selected values of the variables; otherwise, do not allow.
#' @param dataname (`character`)
#' the name of the dataset this filter covers. Set during the initialization of the `teal` application.
#' @param initialized (`logical`)
#' 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.
#'
#' @seealso filter_spec
#'
#' @keywords internal
#'
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,
                                              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, "delayed_choices")
  )

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

#' @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)
  )
  checkmate::assert_vector(vars_choices, unique = TRUE)

  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)
    )
    checkmate::assert_vector(vars_selected, unique = TRUE)
    checkmate::assert_subset(vars_selected, vars_choices)
  }

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

  if (!is.null(selected) && !inherits(selected, "delayed_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)
    )
    checkmate::assert_vector(selected, unique = TRUE)
    checkmate::assert_subset(selected, choices)
  }

  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 = "filter_spec"
  )
}

#' Bare constructor for `delayed_choices` object
#'
#' @description
#'
#' Special S3 structures that delay selection of possible choices in a
#' `filter_spec`, `select_spec` or `choices_selected` object.
#'
#' @param n positive (`integer`-like) number of first/last items to subset to
#'
#' @return
#' Object of class `delayed_data, delayed_choices`, which is a function
#' that returns the appropriate subset of its argument.
#' `all_choices`, `first_choices`, and `last_choices` structures
#' also have an additional class for internal use.
#'
#' @examples
#' # These pairs of structures represent semantically identical specifications:
#' choices_selected(choices = letters, selected = letters)
#' choices_selected(choices = letters, selected = all_choices())
#'
#' choices_selected(choices = letters, selected = letters[1])
#' choices_selected(choices = letters, selected = first_choice())
#'
#' choices_selected(choices = letters, selected = letters[length(letters)])
#' choices_selected(choices = letters, selected = last_choice())
#'
#' choices_selected(choices = letters, selected = head(letters, 4))
#' choices_selected(choices = letters, selected = first_choices(4))
#'
#' choices_selected(choices = letters, selected = tail(letters, 4))
#' choices_selected(choices = letters, selected = last_choices(4))
#'
#' filter_spec(
#'   vars = c("selected_variable"),
#'   choices = c("value1", "value2", "value3"),
#'   selected = "value3"
#' )
#' filter_spec(
#'   vars = c("selected_variable"),
#'   choices = c("value1", "value2", "value3"),
#'   selected = last_choice()
#' )
#'
#' @name delayed_choices

#' @export
#' @rdname delayed_choices
all_choices <- function() {
  ans <- .delayed_choices(identity)
  class(ans) <- c("multiple_choices", class(ans))
  ans
}
#' @export
#' @rdname delayed_choices
first_choice <- function() {
  .delayed_choices(function(x) utils::head(x, 1L))
}
#' @export
#' @rdname delayed_choices
last_choice <- function() {
  .delayed_choices(function(x) utils::tail(x, 1L))
}
#' @export
#' @rdname delayed_choices
first_choices <- function(n) {
  checkmate::assert_count(n, positive = TRUE)
  ans <- .delayed_choices(function(x) utils::head(x, n))
  class(ans) <- c("multiple_choices", class(ans))
  ans
}
#' @export
#' @rdname delayed_choices
last_choices <- function(n) {
  checkmate::assert_count(n, positive = TRUE)
  ans <- .delayed_choices(function(x) utils::tail(x, n))
  class(ans) <- c("multiple_choices", class(ans))
  ans
}

#' @keywords internal
#' @noRd
.delayed_choices <- function(fun) {
  structure(
    function(x) {
      if (inherits(x, "delayed_choices")) {
        x
      } else if (length(x) == 0L) {
        x
      } else if (is.atomic(x)) {
        fun(x)
      } else if (inherits(x, "delayed_data")) {
        if (is.null(x$subset)) {
          return(x)
        }
        original_fun <- x$subset
        x$subset <- function(data) {
          fun(original_fun(data))
        }
        x
      }
    },
    class = c("delayed_choices", "delayed_data")
  )
}

#' Formatting data extracts
#'
#' Returns a human-readable string representation of an extracted `data_extract_spec` object.
#'
#' 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)` representation of the `data_extract` object.
#'
#' @examples
#' library(shiny)
#'
#' 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"))
#' )
#'
#' ui <- bslib::page_fluid(
#'   data_extract_ui(
#'     id = "extract",
#'     label = "data extract ui",
#'     data_extract_spec = simple_des,
#'     is_single_dataset = TRUE
#'   ),
#'   verbatimTextOutput("formatted_extract")
#' )
#' server <- function(input, output, session) {
#'   extracted_input <- data_extract_srv(
#'     id = "extract",
#'     datasets = list(iris = iris),
#'     data_extract_spec = simple_des
#'   )
#'   output$formatted_extract <- renderPrint({
#'     cat(format_data_extract(extracted_input()))
#'   })
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @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")
}

#' 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_debug(
        "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_debug("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_debug("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_debug("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` or `call` or `character(1)`)
#' name of the variable
#'
#' @returns the parsed `varname`.
#'
#' @keywords internal
#'
call_check_parse_varname <- function(varname) {
  checkmate::assert(
    checkmate::check_string(varname),
    checkmate::check_class(varname, "call"),
    checkmate::check_class(varname, "name")
  )
  if (is.character(varname)) {
    parsed <- parse(text = varname, keep.source = FALSE)
    if (length(parsed) == 1) {
      varname <- parsed[[1]]
    } else {
      stop(
        sprintf(
          "Problem with parsing '%s'. Not able to process multiple calls",
          varname
        )
      )
    }
  }
  varname
}

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

  dataname <- call_check_parse_varname(dataname)

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

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


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

  Reduce(
    x = calls,
    f = function(x, y) call(operator, x, y)
  )
}

#' Check if a call or list of calls uses the pipe operator (%>%)
#'
#' Recursively searches through a call or list of calls to determine
#' if the pipe operator `%>%` is used anywhere.
#'
#' @param x (`call`, `name`, or `list` of calls) The call(s) to check.
#'
#' @return `logical(1)` `TRUE` if `%>%` is found, `FALSE` otherwise.
#'
#' @keywords internal
#'
call_uses_magrittr_pipe <- function(x) {
  if (is.call(x)) {
    # Check if there is the pipe operator
    # Handle both quote(`%>%`) and as.name("%>%") cases
    return(any(grepl("%>%", x, fixed = TRUE)))
  }

  if (is.list(x) && length(x)) {
    # Check all elements in the list
    for (call_x in x) {
      if (Recall(call_x)) {
        return(TRUE)
      }
    }
  }

  FALSE
}

#' Split by separator (matched exactly)
#'
#' @param x (`character`) Character vector, each element of which is to be split.
#' Other inputs, including a factor return themselves.
#' @param sep (`character`) separator to use for splitting.
#'
#' @return List of character vectors split by `sep`. Self if `x` is not a `character`.
#'
#' @export
#'
split_by_sep <- function(x, sep) {
  checkmate::assert_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 (`list` or `vector`) optional, with subset of `choices` 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))]
  }

  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.
#'
#' @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))
#'
#' ui <- bslib::page_fluid(
#'   useShinyjs(),
#'   bslib::layout_sidebar(
#'     verbatimTextOutput("out1"),
#'     sidebar = 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) {
#'   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"),
#'         function(x) if (length(x) != 2) "Exactly 2 'Y' column variables must be chosen"
#'       )
#'     )
#'   )
#'   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()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
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
}

#' Ensures datasets is a list of reactive expression
#'
#' @param datasets (`reactive` or `teal_data` or `list`) of `data.frame`
#' wrapped or not in a reactive expression.
#'
#' @return List of `reactive` expressions that contains all the individual `datasets`.
#'
#' @keywords internal
#'
convert_teal_data <- function(datasets) {
  if (is.list(datasets)) {
    sapply(X = datasets, simplify = FALSE, FUN = function(x) {
      if (is.reactive(x)) x else reactive(x)
    })
  } else if (is.reactive(datasets) && inherits(isolate(datasets()), "teal_data")) {
    sapply(
      isolate(names(datasets())),
      function(dataname) {
        reactive(datasets()[[dataname]])
      },
      simplify = FALSE
    )
  } else {
    stop("datasets must be a list of reactive dataframes or a teal_data object")
  }
}

#' Help text with available datasets input
#'
#' @description
#'
#' Creates [shiny::helpText()] with the names of available datasets for the
#' current module.
#'
#' @param data_extracts (`list`) of data extracts for single variable.
#'
#' @return `shiny.tag` defining help-text element that can be added to a UI element.
#'
#' @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
#'
#' Fetches `dataname` slot per `data_extract_spec` from a list of
#' `data_extract_spec`.
#'
#' @param data_extracts (`data_extract_spec(1)`) object or a list (of lists)
#' of `data_extract_spec`.
#'
#' @return `character` vector with the unique `dataname` set.
#'
#' @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))
}

#' Verify uniform dataset source across data extract specification
#'
#' @description
#'
#' Checks if the input `data_extract_spec` objects all come from the same dataset.
#'
#' @param ... either `data_extract_spec` objects or lists of `data_extract_spec`
#' objects that do not contain `NULL`
#'
#' @return `TRUE` if all `data_extract_spec` objects come from the same dataset,
#' `FALSE` otherwise.
#'
#' @export
#'
is_single_dataset <- function(...) {
  data_extract_spec <- list(...)
  dataset_names <- get_extract_datanames(data_extract_spec)
  length(dataset_names) == 1
}

# 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 specification is in list format
#'
#' @param x (`data_extract_spec` or `list`) of `data_extract_spec` elements.
#' @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
#'
#' Stops if condition not met.
#'
#' @param extract_input (`list` or `NULL`) a list of `data_extract_spec`
#'
#' @return Raises an error when check fails, otherwise, it returns `NULL`, invisibly.
#'
#' @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)
}

#' Data extract input for `teal` modules
#'
#' @description
#'
#' 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 No checks based on columns can be done because the data is only referred to by name.
#'
#' @rdname data_extract_spec
#'
#' @section Module Development:
#' `teal.transform` uses this object to construct a UI element in a module.
#'
#' @param dataname (`character`)
#' The name of the dataset to be extracted.
#' @param select (`NULL` or `select_spec`-S3 class or `delayed_select_spec`)
#' 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)
#' 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`)
#' whether reshape long to wide.
#' Note that it will be used only in case of long dataset with multiple
#' keys selected in filter part.
#'
#' @return `data_extract_spec` object.
#'
#' @references [select_spec] [filter_spec]
#'
#' @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
#' )
#' @export
#'
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"
    )
  }
}

#' Merge expression module
#'
#' @description
#'
#' 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`)
#' 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 (`join_keys`)
#' 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`).
#' @param merge_function (`character(1)`)
#' 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)`)
#' Name of the analysis dataset.
#'
#' @return Reactive expression with output from [merge_expression_srv()].
#'
#' @seealso [merge_expression_srv()]
#'
#' @examples
#' library(shiny)
#' library(teal.data)
#' library(teal.widgets)
#'
#' 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 = reactive(ADSL),
#'   ADLB = reactive(ADLB)
#' )
#'
#' join_keys <- join_keys(
#'   join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")),
#'   join_key("ADSL", "ADLB", c("STUDYID", "USUBJID")),
#'   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
#'   )
#' )
#'
#' ui <- bslib::page_fluid(
#'   bslib::layout_sidebar(
#'     tags$div(
#'       verbatimTextOutput("expr"),
#'       dataTableOutput("data")
#'     ),
#'     sidebar = 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 <- qenv()
#'
#'   data_q <- 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 <- 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 <- eval_code(data_q, exp)
#'     data_q
#'   })
#'
#'   output$expr <- renderText(paste(merged_data()$expr, collapse = "\n"))
#'   output$data <- renderDataTable(code_merge()[["ANL"]])
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
merge_expression_module <- function(datasets,
                                    join_keys = NULL,
                                    data_extract,
                                    merge_function = "dplyr::full_join",
                                    anl_name = "ANL",
                                    id = "merge_id") {
  UseMethod("merge_expression_module", datasets)
}

#' @rdname merge_expression_module
#' @export
#'
merge_expression_module.reactive <- function(datasets,
                                             join_keys = NULL,
                                             data_extract,
                                             merge_function = "dplyr::full_join",
                                             anl_name = "ANL",
                                             id = "merge_id") {
  checkmate::assert_class(isolate(datasets()), "teal_data")
  datasets_new <- convert_teal_data(datasets)
  if (is.reactive(datasets) && inherits(isolate(datasets()), "teal_data")) {
    join_keys <- isolate(teal.data::join_keys(datasets()))
  }
  merge_expression_module(datasets_new, join_keys, data_extract, merge_function, anl_name, id)
}

#' @rdname merge_expression_module
#' @export
#'
merge_expression_module.list <- function(datasets,
                                         join_keys = NULL,
                                         data_extract,
                                         merge_function = "dplyr::full_join",
                                         anl_name = "ANL",
                                         id = "merge_id") {
  logger::log_debug("merge_expression_module called with: { paste(names(datasets), collapse = ', ') } datasets.")
  checkmate::assert_list(datasets, names = "named")
  checkmate::assert_list(data_extract, names = "named", types = c("list", "data_extract_spec", "NULL"))
  checkmate::assert_class(join_keys, "join_keys")
  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
#'
#' 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 merge_expression_module
#' @param selector_list (`reactive`)
#' 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`)
#'  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)`)
#'  Name of the analysis dataset.
#'
#' @inherit merge_expression_module return
#'
#' @seealso [merge_expression_module()]
#'
#' @examples
#' library(shiny)
#' library(teal.data)
#' library(teal.widgets)
#'
#' 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 = reactive(ADSL),
#'   ADLB = reactive(ADLB)
#' )
#'
#' join_keys <- join_keys(
#'   join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")),
#'   join_key("ADSL", "ADLB", c("STUDYID", "USUBJID")),
#'   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
#'   )
#' )
#'
#' ui <- bslib::page_fluid(
#'   bslib::layout_sidebar(
#'     tags$div(
#'       verbatimTextOutput("expr"),
#'       dataTableOutput("data")
#'     ),
#'     sidebar = 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 <- qenv()
#'
#'   data_q <- 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 <- 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 <- eval_code(data_q, exp)
#'     data_q
#'   })
#'
#'   output$expr <- renderText(paste(merged_data()$expr, collapse = "\n"))
#'   output$data <- renderDataTable(code_merge()[["ANL"]])
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
merge_expression_srv <- function(id = "merge_id",
                                 selector_list,
                                 datasets,
                                 join_keys,
                                 merge_function = "dplyr::full_join",
                                 anl_name = "ANL") {
  UseMethod("merge_expression_srv", datasets)
}

#' @rdname merge_expression_srv
#' @export
merge_expression_srv.reactive <- function(id = "merge_id",
                                          selector_list,
                                          datasets,
                                          join_keys,
                                          merge_function = "dplyr::full_join",
                                          anl_name = "ANL") {
  checkmate::assert_class(isolate(datasets()), "teal_data")
  datasets_new <- convert_teal_data(datasets)
  if (is.reactive(datasets) && inherits(isolate(datasets()), "teal_data")) {
    join_keys <- isolate(teal.data::join_keys(datasets()))
  }
  merge_expression_srv(id, selector_list, datasets_new, join_keys, merge_function, anl_name)
}

#' @rdname merge_expression_srv
#' @export
merge_expression_srv.list <- function(id = "merge_id",
                                      selector_list,
                                      datasets,
                                      join_keys,
                                      merge_function = "dplyr::full_join",
                                      anl_name = "ANL") {
  checkmate::assert_list(datasets, names = "named")
  checkmate::assert_string(anl_name)
  stopifnot(make.names(anl_name) == anl_name)
  checkmate::assert_class(selector_list, "reactive")
  checkmate::assert_class(join_keys, "join_keys")

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

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

#' 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
#'
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 = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_label),
    choices = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_choices),
    selected = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_selected),
    multiple = filter$vars_multiple,
    fixed = filter$vars_fixed
  )

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

  tags$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()].
#'
#' @return `NULL`, invisibly.
#'
#' @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_debug("data_extract_filter_srv initialized with: { filter$dataname } dataset.")

      isolate({
        # when the filter is initialized with a delayed spec, the choices and selected are NULL
        # here delayed are resolved and the values are set up
        # Begin by resolving delayed choices.
        if (inherits(filter$selected, "delayed_choices")) {
          filter$selected <- filter$selected(filter$choices)
        }
        teal.widgets::updateOptionalSelectInput(
          session = session,
          inputId = "col",
          choices = filter$vars_choices,
          selected = filter$vars_selected
        )
        teal.widgets::updateOptionalSelectInput(
          session = session,
          inputId = "vals",
          choices = filter$choices,
          selected = filter$selected
        )
      })

      observeEvent(
        input$col,
        ignoreInit = TRUE, # When observeEvent is initialized input$col is still NULL as it is set few lines above
        ignoreNULL = FALSE, # columns could be NULL, then vals should be set to NULL also
        handlerExpr = {
          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_debug("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
          )
        }
      )
    }
  )
}

#' 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
#'
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, "delayed_choices")) {
      filter$selected(initial_values$choices)
    } else {
      filter$selected
    }
  } else {
    initial_values$choices <- filter$choices
    initial_values$selected <- filter$selected
  }

  initial_values
}

#' Check if the merge function is valid
#'
#' @param merge_function (`character`) merge function name.
#'
#' @return Raises an error when check fails, otherwise, it returns `NULL`, invisibly.
#'
#' @keywords internal
#'
check_merge_function <- function(merge_function) {
  checkmate::assert_string(merge_function)
  stopifnot(length(intersect(methods::formalArgs(eval(rlang::parse_expr(merge_function))), c("x", "y", "by"))) == 3)
}

#' Check selector `dataname` element
#'
#' @param dataname (`character(1)`) selector element.
#'
#' @return Raises an error when check fails, otherwise, it returns the `dataname`
#' parameter, invisibly and unchanged.
#'
#' @keywords internal
#'
check_selector_dataname <- function(dataname) {
  checkmate::assert_string(dataname)
}

#' Check selector filters element
#'
#' @param filters (`list`) selector element generated by `data_extract_srv`.
#'
#' @return Raises an error when the check fails, otherwise it returns `NULL`, invisibly.
#'
#' @keywords internal
#'
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 (`character`) selector element generated by `data_extract_srv`.
#'
#' @return Raises an error when check fails, otherwise, it returns the `select`
#' parameter, invisibly and unchanged.
#'
#' @keywords internal
#'
check_selector_select <- function(select) {
  checkmate::assert_character(select)
}

#' Check selector keys element
#'
#' @param keys (`character`) selector element generated by `data_extract_srv`.
#'
#' @return Raises an error when check fails, otherwise, it returns the `keys`
#' parameter, invisibly and unchanged.
#'
#' @keywords internal
#'
check_selector_keys <- function(keys) {
  checkmate::assert_character(keys, min.len = 0L, any.missing = FALSE)
}

#' Check selector reshape element
#'
#' @param reshape (`logical(1)`) selector element generated by `data_extract_srv`.
#'
#' @return Raises an error when check fails, otherwise, it returns the `reshape`
#' parameter, invisibly and unchanged.
#'
#' @keywords internal
#'
check_selector_reshape <- function(reshape) {
  checkmate::assert_flag(reshape)
}

#' Check selector internal_id element
#'
#' @param internal_id (`character(1)`) selector element generated by `data_extract_srv`.
#'
#' @return Raises an error when check fails, otherwise, it returns the `internal_id`
#' parameter, invisibly and unchanged.
#'
#' @keywords internal
#'
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 Raises an error when check fails, otherwise, it returns the `selector`
#' parameter, invisibly and unchanged.
#'
#' @keywords internal
#'
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)
  )
  invisible(selector)
}

# Queue ====

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

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

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

#' Column selection input specification
#'
#' @description
#'
#' `select_spec` is used inside `teal` to create a [shiny::selectInput()]
#' that will select columns from a dataset.
#'
#' @rdname select_spec
#'
#' @param choices (`character` or `delayed_data`) object.
#' Named character vector to define the choices of a shiny [shiny::selectInput()].
#' These have to be columns in the dataset defined in the [data_extract_spec()]
#' where this is called.
#' `delayed_data` objects can be created via [variable_choices()] or [value_choices()].
#' @param selected (`character` or `NULL` or `delayed_choices` or `delayed_data`) optional
#' named character vector to define the selected values of a shiny [shiny::selectInput()].
#' Passing a `delayed_choices` object defers selection until data is available.
#' Defaults to the first value of `choices` or `NULL` for delayed data loading.
#' @param multiple (`logical`) Whether multiple values shall be allowed in the
#' shiny [shiny::selectInput()].
#' @param fixed (`logical`) optional [data_extract_spec()] specific feature to
#' hide the choices selected in case they are not needed. Setting fixed to `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 (`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 (`character`) optional, defines a label on top of this specific
#' shiny [shiny::selectInput()]. The default value is `"Select"`.
#'
#' @return A `select_spec`-S3 class object or `delayed_select_spec`-S3-class object.
#' It contains all input values.
#'
#' If `select_spec`, then the function double checks the `choices` and `selected` inputs.
#'
#' @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
#' )
#'
#' # delayed_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())
#' @export
#'
select_spec <- function(choices,
                        selected = `if`(inherits(choices, "delayed_data"), NULL, choices[1]),
                        multiple = length(selected) > 1 || inherits(selected, "multiple_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, "multiple_choices"))
  if (fixed) stopifnot(is.null(always_selected))

  if (inherits(selected, "delayed_choices")) selected <- 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: object_name_linter.
                                     selected = NULL,
                                     multiple = length(selected) > 1,
                                     fixed = FALSE,
                                     always_selected = NULL,
                                     ordered = FALSE,
                                     label = NULL) {
  checkmate::assert(
    checkmate::check_null(selected),
    checkmate::check_atomic(selected),
    checkmate::check_class(selected, "delayed_data")
  )
  checkmate::assert(
    checkmate::check_null(choices),
    checkmate::check_atomic(choices),
    checkmate::check_class(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: object_name_linter.
                                selected = choices[1],
                                multiple = length(selected) > 1,
                                fixed = FALSE,
                                always_selected = NULL,
                                ordered = FALSE,
                                label = NULL) {
  checkmate::assert(
    checkmate::check_null(choices),
    checkmate::check_atomic(choices)
  )
  checkmate::assert(
    checkmate::check_null(selected),
    checkmate::check_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) {
    checkmate::assert_atomic(selected)
    checkmate::assert_subset(selected, 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
    }
  }

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

#' Resolve delayed inputs by evaluating the code within the provided datasets
#'
#' @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.
#'
#' @examples
#' library(shiny)
#'
#' ADSL <- teal.data::rADSL
#' isolate({
#'   data_list <- list(ADSL = reactive(ADSL))
#'
#'   # value_choices example
#'   v1 <- value_choices("ADSL", "SEX", "SEX")
#'   v1
#'   resolve_delayed(v1, data_list)
#'
#'   # variable_choices example
#'   v2 <- variable_choices("ADSL", c("BMRKR1", "BMRKR2"))
#'   v2
#'   resolve_delayed(v2, data_list)
#'
#'   # 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, datasets = data_list)
#'   resolve_delayed(adsl_select, datasets = data_list)
#'   resolve_delayed(adsl_de, datasets = data_list)
#'
#'   # nested list (arm_ref_comp)
#'   arm_ref_comp <- list(
#'     ARMCD = list(
#'       ref = variable_choices("ADSL"),
#'       comp = variable_choices("ADSL")
#'     )
#'   )
#'
#'   resolve_delayed(arm_ref_comp, datasets = data_list)
#' })
#' @export
#'
resolve_delayed <- function(x, datasets, keys) {
  UseMethod("resolve_delayed", datasets)
}

#' @describeIn resolve_delayed Default values for `keys` parameters is extracted from `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)
}

#' @describeIn resolve_delayed Generic method when `datasets` argument is a named list.
#' @export
resolve_delayed.list <- function(x, datasets, keys = NULL) {
  checkmate::assert_list(datasets, types = 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)
}

#' Returns non-key column names from data
#'
#' @description Returns non-key column names from data.
#'
#' @param data (`data.frame`) Data with attribute `filter_and_columns`. This can only be
#' created by [data_extract_srv()], which returns a shiny [shiny::reactive()].
#'
#' @return A named `character` vector with the non-key columns of the `data`.
#'
#' @references [data_extract_srv()]
#'
#' @export
#'
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
  }
}

#' 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
#'
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 = `if`(inherits(select, "delayed_select_spec"), NULL, select$choices),
      selected = `if`(inherits(select, "delayed_select_spec"), NULL, 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)
}

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

1		#' Bare constructor for `delayed_choices` object
2		#'
3		#' @description
4		#'
5		#' Special S3 structures that delay selection of possible choices in a
6		#' `filter_spec`, `select_spec` or `choices_selected` object.
7		#'
8		#' @param n positive (`integer`-like) number of first/last items to subset to
9		#'
10		#' @return
11		#' Object of class `delayed_data, delayed_choices`, which is a function
12		#' that returns the appropriate subset of its argument.
13		#' `all_choices`, `first_choices`, and `last_choices` structures
14		#' also have an additional class for internal use.
15		#'
16		#' @examples
17		#' # These pairs of structures represent semantically identical specifications:
18		#' choices_selected(choices = letters, selected = letters)
19		#' choices_selected(choices = letters, selected = all_choices())
20		#'
21		#' choices_selected(choices = letters, selected = letters[1])
22		#' choices_selected(choices = letters, selected = first_choice())
23		#'
24		#' choices_selected(choices = letters, selected = letters[length(letters)])
25		#' choices_selected(choices = letters, selected = last_choice())
26		#'
27		#' choices_selected(choices = letters, selected = head(letters, 4))
28		#' choices_selected(choices = letters, selected = first_choices(4))
29		#'
30		#' choices_selected(choices = letters, selected = tail(letters, 4))
31		#' choices_selected(choices = letters, selected = last_choices(4))
32		#'
33		#' filter_spec(
34		#' vars = c("selected_variable"),
35		#' choices = c("value1", "value2", "value3"),
36		#' selected = "value3"
37		#' )
38		#' filter_spec(
39		#' vars = c("selected_variable"),
40		#' choices = c("value1", "value2", "value3"),
41		#' selected = last_choice()
42		#' )
43		#'
44		#' @name delayed_choices
45
46		#' @export
47		#' @rdname delayed_choices
48		all_choices <- function() {
49	16x	ans <- .delayed_choices(identity)
50	16x	class(ans) <- c("multiple_choices", class(ans))
51	16x	ans
52		}
53		#' @export
54		#' @rdname delayed_choices
55		first_choice <- function() {
56	8x	.delayed_choices(function(x) utils::head(x, 1L))
57		}
58		#' @export
59		#' @rdname delayed_choices
60		last_choice <- function() {
61	8x	.delayed_choices(function(x) utils::tail(x, 1L))
62		}
63		#' @export
64		#' @rdname delayed_choices
65		first_choices <- function(n) {
66	9x	checkmate::assert_count(n, positive = TRUE)
67	8x	ans <- .delayed_choices(function(x) utils::head(x, n))
68	8x	class(ans) <- c("multiple_choices", class(ans))
69	8x	ans
70		}
71		#' @export
72		#' @rdname delayed_choices
73		last_choices <- function(n) {
74	9x	checkmate::assert_count(n, positive = TRUE)
75	8x	ans <- .delayed_choices(function(x) utils::tail(x, n))
76	8x	class(ans) <- c("multiple_choices", class(ans))
77	8x	ans
78		}
79
80		#' @keywords internal
81		#' @noRd
82		.delayed_choices <- function(fun) {
83	48x	structure(
84	48x	function(x) {
85	33x	if (inherits(x, "delayed_choices")) {
86	!	x
87	33x	} else if (length(x) == 0L) {
88	11x	x
89	22x	} else if (is.atomic(x)) {
90	21x	fun(x)
91	1x	} else if (inherits(x, "delayed_data")) {
92	1x	if (is.null(x$subset)) {
93	1x	return(x)
94		}
95	!	original_fun <- x$subset
96	!	x$subset <- function(data) {
97	!	fun(original_fun(data))
98		}
99	!	x
100		}
101		},
102	48x	class = c("delayed_choices", "delayed_data")
103		)
104		}

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

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

1		#' Split by separator (matched exactly)
2		#'
3		#' @param x (`character`) Character vector, each element of which is to be split.
4		#' Other inputs, including a factor return themselves.
5		#' @param sep (`character`) separator to use for splitting.
6		#'
7		#' @return List of character vectors split by `sep`. Self if `x` is not a `character`.
8		#'
9		#' @export
10		#'
11		split_by_sep <- function(x, sep) {
12	78x	checkmate::assert_atomic(x)
13	78x	if (is.character(x)) {
14	73x	strsplit(x, sep, fixed = TRUE)
15		} else {
16	5x	x
17		}
18		}
19
20		#' Extract labels from choices basing on attributes and names
21		#'
22		#' @param choices (`list` or `vector`) select choices.
23		#' @param values (`list` or `vector`) optional, with subset of `choices` for which
24		#' labels should be extracted, `NULL` for all choices.
25		#'
26		#' @return `character` vector with labels.
27		#'
28		#' @keywords internal
29		#'
30		extract_choices_labels <- function(choices, values = NULL) {
31	!	res <- if (inherits(choices, "choices_labeled")) {
32	!	attr(choices, "raw_labels")
33	!	} else if (!is.null(names(choices)) && !setequal(names(choices), unlist(unname(choices)))) {
34	!	names(choices)
35		} else {
36	!	NULL
37		}
38
39	!	if (!is.null(values) && !is.null(res)) {
40	!	stopifnot(all(values %in% choices))
41	!	res <- res[vapply(values, function(val) which(val == choices), numeric(1))]
42		}
43
44	!	res
45		}
46
47		#' Function to compose `validators` from `data_extract_multiple_srv`
48		#'
49		#' This function takes the output from `data_extract_multiple_srv` and
50		#' collates the `shinyvalidate::InputValidator`s returned into a single
51		#' `validator` and enables this.
52		#'
53		#' @param iv (`shinyvalidate::InputValidator`) A `validator`.
54		#' @param selector_list (`reactive` named list of `reactives`).
55		#' Typically this is the output from `data_extract_multiple_srv`.
56		#' The `validators` in this list (specifically `selector_list()[[validator_names]]()iv`)
57		#' will be added into `iv`.
58		#' @param validator_names (`character` or `NULL`). If `character` then only `validators`
59		#' in the elements of `selector_list()` whose name is in this list will be added. If `NULL`
60		#' all `validators` will be added
61		#'
62		#' @return (`shinyvalidate::InputValidator`) enabled `iv` with appropriate `validators` added into it.
63		#'
64		#' @examples
65		#' library(shiny)
66		#' library(shinyvalidate)
67		#' library(shinyjs)
68		#' library(teal.widgets)
69		#'
70		#' iris_extract <- data_extract_spec(
71		#' dataname = "iris",
72		#' select = select_spec(
73		#' label = "Select variable:",
74		#' choices = variable_choices(iris, colnames(iris)),
75		#' selected = "Sepal.Length",
76		#' multiple = TRUE,
77		#' fixed = FALSE
78		#' )
79		#' )
80		#'
81		#' data_list <- list(iris = reactive(iris))
82		#'
83		#' ui <- bslib::page_fluid(
84		#' useShinyjs(),
85		#' bslib::layout_sidebar(
86		#' verbatimTextOutput("out1"),
87		#' sidebar = tagList(
88		#' data_extract_ui(
89		#' id = "x_var",
90		#' label = "Please select an X column",
91		#' data_extract_spec = iris_extract
92		#' ),
93		#' data_extract_ui(
94		#' id = "y_var",
95		#' label = "Please select a Y column",
96		#' data_extract_spec = iris_extract
97		#' ),
98		#' data_extract_ui(
99		#' id = "col_var",
100		#' label = "Please select a color column",
101		#' data_extract_spec = iris_extract
102		#' )
103		#' )
104		#' )
105		#' )
106		#'
107		#' server <- function(input, output, session) {
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		#' function(x) if (length(x) != 2) "Exactly 2 'Y' column variables must be chosen"
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		#' shinyApp(ui, server)
143		#' }
144		#' @export
145		#'
146		compose_and_enable_validators <- function(iv, selector_list, validator_names = NULL) {
147	7x	if (is.null(validator_names)) {
148	7x	validator_names <- names(selector_list())
149		}
150	7x	valid_validator_names <- intersect(validator_names, names(selector_list()))
151
152	7x	for (validator_name in valid_validator_names) {
153	14x	single_des <- selector_list()[[validator_name]]()
154	14x	if (!is.null(single_des$iv)) {
155	14x	iv$add_validator(single_des$iv)
156		}
157		}
158	7x	iv$enable()
159	7x	iv
160		}
161
162		#' Ensures datasets is a list of reactive expression
163		#'
164		#' @param datasets (`reactive` or `teal_data` or `list`) of `data.frame`
165		#' wrapped or not in a reactive expression.
166		#'
167		#' @return List of `reactive` expressions that contains all the individual `datasets`.
168		#'
169		#' @keywords internal
170		#'
171		convert_teal_data <- function(datasets) {
172	!	if (is.list(datasets)) {
173	!	sapply(X = datasets, simplify = FALSE, FUN = function(x) {
174	!	if (is.reactive(x)) x else reactive(x)
175		})
176	!	} else if (is.reactive(datasets) && inherits(isolate(datasets()), "teal_data")) {
177	!	sapply(
178	!	isolate(names(datasets())),
179	!	function(dataname) {
180	!	reactive(datasets()[[dataname]])
181		},
182	!	simplify = FALSE
183		)
184		} else {
185	!	stop("datasets must be a list of reactive dataframes or a teal_data object")
186		}
187		}

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

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

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

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

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

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

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

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

1		#' Help text with available datasets input
2		#'
3		#' @description
4		#'
5		#' Creates [shiny::helpText()] with the names of available datasets for the
6		#' current module.
7		#'
8		#' @param data_extracts (`list`) of data extracts for single variable.
9		#'
10		#' @return `shiny.tag` defining help-text element that can be added to a UI element.
11		#'
12		#' @export
13		#'
14		datanames_input <- function(data_extracts) {
15	!	datanames <- get_extract_datanames(data_extracts)
16	!	helpText(
17	!	paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
18	!	tags$code(paste(datanames, collapse = ", "))
19		)
20		}
21
22		#' Gets names of the datasets from a list of `data_extract_spec` objects
23		#'
24		#' @description
25		#'
26		#' Fetches `dataname` slot per `data_extract_spec` from a list of
27		#' `data_extract_spec`.
28		#'
29		#' @param data_extracts (`data_extract_spec(1)`) object or a list (of lists)
30		#' of `data_extract_spec`.
31		#'
32		#' @return `character` vector with the unique `dataname` set.
33		#'
34		#' @export
35		#'
36		get_extract_datanames <- function(data_extracts) {
37	17x	data_extracts <- if (inherits(data_extracts, "data_extract_spec")) {
38	2x	list(data_extracts)
39		} else {
40	15x	data_extracts
41		}
42	17x	checkmate::assert_list(data_extracts)
43
44	14x	data_extracts <- Filter(Negate(is.null), data_extracts)
45	14x	data_extracts <- Filter(Negate(is.logical), data_extracts)
46	14x	data_extracts <- Filter(Negate(is.choices_selected), data_extracts)
47
48	14x	stopifnot(length(data_extracts) > 0)
49	13x	stopifnot(
50	13x	checkmate::test_list(data_extracts, types = "data_extract_spec") \|\|
51	13x	all(vapply(data_extracts, function(x) checkmate::test_list(x, types = "data_extract_spec"), logical(1)))
52		)
53
54	11x	datanames <- lapply(data_extracts, function(x) {
55	20x	if (inherits(x, "data_extract_spec")) {
56	12x	x[["dataname"]]
57	8x	} else if (checkmate::test_list(x, types = "data_extract_spec")) {
58	8x	lapply(x, `[[`, "dataname")
59		}
60		})
61
62	11x	unique(unlist(datanames))
63		}
64
65		#' Verify uniform dataset source across data extract specification
66		#'
67		#' @description
68		#'
69		#' Checks if the input `data_extract_spec` objects all come from the same dataset.
70		#'
71		#' @param ... either `data_extract_spec` objects or lists of `data_extract_spec`
72		#' objects that do not contain `NULL`
73		#'
74		#' @return `TRUE` if all `data_extract_spec` objects come from the same dataset,
75		#' `FALSE` otherwise.
76		#'
77		#' @export
78		#'
79		is_single_dataset <- function(...) {
80	!	data_extract_spec <- list(...)
81	!	dataset_names <- get_extract_datanames(data_extract_spec)
82	!	length(dataset_names) == 1
83		}

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 specification is in list format
6		#'
7		#' @param x (`data_extract_spec` or `list`) of `data_extract_spec` elements.
8		#' @param allow_null (`logical`) whether x can be `NULL`.
9		#'
10		#' @return `x` as a list if it is not already.
11		#'
12		#' @export
13		list_extract_spec <- function(x, allow_null = FALSE) {
14	6x	if (is.null(x)) {
15	!	stopifnot(allow_null)
16	!	return(NULL)
17		}
18	6x	if (!checkmate::test_list(x, types = "data_extract_spec")) {
19	5x	x <- list(x)
20		}
21	6x	stopifnot(checkmate::test_list(x, types = "data_extract_spec"))
22	6x	x
23		}
24
25		#' Checks that the `extract_input` specification does not allow multiple
26		#' selection
27		#'
28		#' Stops if condition not met.
29		#'
30		#' @param extract_input (`list` or `NULL`) a list of `data_extract_spec`
31		#'
32		#' @return Raises an error when check fails, otherwise, it returns `NULL`, invisibly.
33		#'
34		#' @export
35		#'
36		check_no_multiple_selection <- function(extract_input) {
37		# bug in is_class_list when NULL
38	3x	checkmate::assert_list(extract_input, types = "data_extract_spec", null.ok = TRUE)
39	2x	all(vapply(extract_input, function(elem) !isTRUE(elem$select$multiple), logical(1))) \|\|
40	2x	stop("extract_input variable should not allow multiple selection")
41	1x	invisible(NULL)
42		}

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

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

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

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		#'
11		#' @keywords internal
12		#'
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 = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_label),
22	6x	choices = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_choices),
23	6x	selected = `if`(inherits(filter, "delayed_filter_spec"), NULL, 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 = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$choices),
32	6x	selected = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$selected),
33	6x	multiple = filter$multiple,
34	6x	fixed = filter$fixed
35		)
36
37	6x	tags$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.
48		#' It's responsible 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		#'
55		#' @return `NULL`, invisibly.
56		#'
57		#' @keywords internal
58		#'
59		data_extract_filter_srv <- function(id, datasets, filter) {
60	7x	checkmate::assert_list(datasets, types = "reactive", names = "named")
61	7x	moduleServer(
62	7x	id,
63	7x	function(input, output, session) {
64		# We force the evaluation of filter, otherwise the observers are set up with the last element
65		# of the list in data_extract_single_srv and not all of them (due to R lazy evaluation)
66	7x	force(filter)
67	7x	logger::log_debug("data_extract_filter_srv initialized with: { filter$dataname } dataset.")
68
69	7x	isolate({
70		# when the filter is initialized with a delayed spec, the choices and selected are NULL
71		# here delayed are resolved and the values are set up
72		# Begin by resolving delayed choices.
73	7x	if (inherits(filter$selected, "delayed_choices")) {
74	1x	filter$selected <- filter$selected(filter$choices)
75		}
76	7x	teal.widgets::updateOptionalSelectInput(
77	7x	session = session,
78	7x	inputId = "col",
79	7x	choices = filter$vars_choices,
80	7x	selected = filter$vars_selected
81		)
82	7x	teal.widgets::updateOptionalSelectInput(
83	7x	session = session,
84	7x	inputId = "vals",
85	7x	choices = filter$choices,
86	7x	selected = filter$selected
87		)
88		})
89
90	7x	observeEvent(
91	7x	input$col,
92	7x	ignoreInit = TRUE, # When observeEvent is initialized input$col is still NULL as it is set few lines above
93	7x	ignoreNULL = FALSE, # columns could be NULL, then vals should be set to NULL also
94	7x	handlerExpr = {
95	!	if (!rlang::is_empty(input$col)) {
96	!	choices <- value_choices(
97	!	datasets[[filter$dataname]](),
98	!	input$col,
99	!	`if`(isTRUE(input$col == attr(filter$choices, "var_choices")), attr(filter$choices, "var_label"), NULL)
100		)
101
102	!	selected <- if (!is.null(filter$selected)) {
103	!	filter$selected
104	!	} else if (filter$multiple) {
105	!	choices
106		} else {
107	!	choices[1]
108		}
109		} else {
110	!	choices <- character(0)
111	!	selected <- character(0)
112		}
113	!	dn <- filter$dataname
114	!	fc <- paste(input$col, collapse = ", ")
115	!	logger::log_debug("data_extract_filter_srv@1 filter dataset: { dn }; filter var: { fc }.")
116		# In order to force reactivity we run two updates: (i) set up dummy values (ii) set up appropriate values
117		# It's due to a missing reactivity triggers if new selected value is identical with previously selected one.
118	!	teal.widgets::updateOptionalSelectInput(
119	!	session = session,
120	!	inputId = "vals",
121	!	choices = paste0(input$val, "$_<-_random_text_to_ensure_val_will_be_different_from_previous"),
122	!	selected = paste0(input$val, "$_<-_random_text_to_ensure_val_will_be_different_from_previous")
123		)
124
125	!	teal.widgets::updateOptionalSelectInput(
126	!	session = session,
127	!	inputId = "vals",
128	!	choices = choices,
129	!	selected = selected
130		)
131		}
132		)
133		}
134		)
135		}
136
137		#' Returns the initial values for the `vals` widget of a `filter_spec` object
138		#'
139		#' @inheritParams data_extract_filter_srv
140		#'
141		#' @return named `list` with two slots `choices` and `selected`.
142		#'
143		#' @keywords internal
144		#'
145		get_initial_filter_values <- function(filter, datasets) {
146	!	initial_values <- list()
147	!	if (is.null(filter$vars_selected)) {
148	!	initial_values$choices <- character(0)
149	!	initial_values$selected <- character(0)
150	!	} else if (is.null(filter$choices)) {
151	!	initial_values$choices <- value_choices(
152	!	datasets[[filter$dataname]](),
153	!	as.character(filter$vars_selected)
154		)
155	!	initial_values$selected <- if (inherits(filter$selected, "delayed_choices")) {
156	!	filter$selected(initial_values$choices)
157		} else {
158	!	filter$selected
159		}
160		} else {
161	!	initial_values$choices <- filter$choices
162	!	initial_values$selected <- filter$selected
163		}
164
165	!	initial_values
166		}

1		#' Check if the merge function is valid
2		#'
3		#' @param merge_function (`character`) merge function name.
4		#'
5		#' @return Raises an error when check fails, otherwise, it returns `NULL`, invisibly.
6		#'
7		#' @keywords internal
8		#'
9		check_merge_function <- function(merge_function) {
10	73x	checkmate::assert_string(merge_function)
11	73x	stopifnot(length(intersect(methods::formalArgs(eval(rlang::parse_expr(merge_function))), c("x", "y", "by"))) == 3)
12		}

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

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

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

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

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

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