teal.transform coverage - 81.08%

Files
Source

#' Checks `varname` argument and convert to call
#'
#' Checks `varname` type and parse if it's a `character`.
#'
#' @param varname (`name` or `call` or `character(1)`)
#' name of the variable
#'
#' @returns the parsed `varname`.
#'
#' @keywords internal
#'
call_check_parse_varname <- function(varname) {
  checkmate::assert(
    checkmate::check_string(varname),
    checkmate::check_class(varname, "call"),
    checkmate::check_class(varname, "name")
  )
  if (is.character(varname)) {
    parsed <- parse(text = varname, keep.source = FALSE)
    if (length(parsed) == 1) {
      varname <- 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)
  )
}

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

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

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

#' Column selection input specification
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' `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 `all_choices` or `delayed_data`) optional
#' named character vector to define the selected values of a shiny [shiny::selectInput()].
#' Passing an `all_choices()` object indicates selecting all possible choices.
#' 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
#' )
#'
#' # all_choices passed to selected
#' select_spec(
#'   label = "Select variable:",
#'   choices = variable_choices("ADSL", c("BMRKR1", "BMRKR2")),
#'   selected = all_choices()
#' )
#'
#' # Both below objects are semantically the same
#' select_spec(choices = variable_choices("ADSL"), selected = variable_choices("ADSL"))
#' select_spec(choices = variable_choices("ADSL"), selected = all_choices())
#' @export
#'
select_spec <- function(choices,
                        selected = `if`(inherits(choices, "delayed_data"), NULL, choices[1]),
                        multiple = length(selected) > 1 || inherits(selected, "all_choices"),
                        fixed = FALSE,
                        always_selected = NULL,
                        ordered = FALSE,
                        label = "Select") {
  checkmate::assert_flag(multiple)
  checkmate::assert_flag(fixed)
  checkmate::assert_character(always_selected, min.len = 1, null.ok = TRUE, any.missing = FALSE)
  checkmate::assert_flag(ordered)
  checkmate::assert_string(label, null.ok = TRUE)
  stopifnot(multiple || !inherits(selected, "all_choices"))
  if (fixed) stopifnot(is.null(always_selected))

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

#' @rdname select_spec
#' @export
#'
select_spec.delayed_data <- function(choices, # nolint: 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"
  )
}

# Queue ====

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

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

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

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

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

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

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

#' @rdname data_extract_srv
#' @export
#'
data_extract_srv.FilteredData <- function(id, datasets, data_extract_spec, ...) {
  checkmate::assert_class(datasets, "FilteredData")
  moduleServer(
    id,
    function(input, output, session) {
      logger::log_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
#' `r lifecycle::badge("experimental")`
#'
#' `data_extract_multiple_srv` loops over the list of `data_extract` given and
#' runs `data_extract_srv` for each one returning a list of reactive objects.
#'
#' @inheritParams data_extract_srv
#' @param data_extract (named `list` of `data_extract_spec` objects) the list `data_extract_spec` objects.
#' The names of the elements in the list need to correspond to the `ids` passed to `data_extract_ui`.
#'
#' See example for details.
#'
#' @return reactive named `list` containing outputs from [data_extract_srv()].
#' Output list names are the same as `data_extract` input argument.
#'
#' @examples
#' library(shiny)
#' library(shinyvalidate)
#' library(shinyjs)
#' library(teal.widgets)
#'
#' iris_select <- data_extract_spec(
#'   dataname = "iris",
#'   select = select_spec(
#'     label = "Select variable:",
#'     choices = variable_choices(iris, colnames(iris)),
#'     selected = "Sepal.Length",
#'     multiple = TRUE,
#'     fixed = FALSE
#'   )
#' )
#'
#' iris_filter <- data_extract_spec(
#'   dataname = "iris",
#'   filter = filter_spec(
#'     vars = "Species",
#'     choices = c("setosa", "versicolor", "virginica"),
#'     selected = "setosa",
#'     multiple = TRUE
#'   )
#' )
#'
#' data_list <- list(iris = reactive(iris))
#'
#' ui <- fluidPage(
#'   useShinyjs(),
#'   standard_layout(
#'     output = verbatimTextOutput("out1"),
#'     encoding = tagList(
#'       data_extract_ui(
#'         id = "x_var",
#'         label = "Please select an X column",
#'         data_extract_spec = iris_select
#'       ),
#'       data_extract_ui(
#'         id = "species_var",
#'         label = "Please select 2 Species",
#'         data_extract_spec = iris_filter
#'       )
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   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]]
        )
      }
    )
  })
}

#' Data extract filter specification
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' 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 `all_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.
#' The `all_choices` object indicates selecting all possible choices.
#' @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, "all_choices"),
                        label = "Filter by",
                        sep = attr(choices, "sep"),
                        drop_keys = FALSE) {
  if (is.null(sep)) sep <- " - "
  checkmate::assert(
    checkmate::check_character(vars, min.len = 1, any.missing = FALSE),
    checkmate::check_class(vars, "delayed_data"),
    checkmate::check_class(vars, "choices_selected")
  )
  checkmate::assert(
    checkmate::check_null(choices),
    checkmate::check_character(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(choices, min.len = 1, any.missing = FALSE),
    checkmate::check_class(choices, "delayed_data")
  )
  checkmate::assert(
    checkmate::check_null(selected),
    checkmate::check_character(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_logical(selected, min.len = 1, any.missing = FALSE),
    checkmate::check_class(selected, "delayed_data"),
    checkmate::check_class(selected, "all_choices")
  )

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

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

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


#' Data extract dynamic filter specification
#'
#' 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, "all_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, "all_choices")) {
    stopifnot(multiple || length(selected) == 1)
    checkmate::assert(
      checkmate::check_character(selected, min.len = 1, any.missing = FALSE),
      checkmate::check_numeric(selected, min.len = 1, any.missing = FALSE),
      checkmate::check_logical(selected, min.len = 1, any.missing = FALSE)
    )
    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"
  )
}

#' Merge expression module
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' 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 <- fluidPage(
#'   standard_layout(
#'     output = tags$div(
#'       verbatimTextOutput("expr"),
#'       dataTableOutput("data")
#'     ),
#'     encoding = tagList(
#'       data_extract_ui("adsl_var", label = "ADSL selection", adsl_extract),
#'       data_extract_ui("adlb_var", label = "ADLB selection", adlb_extract)
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   data_q <- 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
#'
#' `r lifecycle::badge("experimental")`
#'
#' 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 <- fluidPage(
#'   standard_layout(
#'     output = tags$div(
#'       verbatimTextOutput("expr"),
#'       dataTableOutput("data")
#'     ),
#'     encoding = tagList(
#'       data_extract_ui("adsl_var", label = "ADSL selection", adsl_extract),
#'       data_extract_ui("adlb_var", label = "ADLB selection", adlb_extract)
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   data_q <- 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
        )
      })
    }
  )
}

no_select_keyword <- "-- no selection --"

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

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

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

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

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

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

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

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

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

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

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

    x
  }
}

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

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

  vec_attrs <- attributes(vec)

  vec <- vec[idx]

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

  attributes(vec) <- vec_attrs
  vec


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

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

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

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

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

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

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