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

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

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

        selected <- split_by_sep(input_vals, x$sep)

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

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

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

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

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

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

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

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

          res
        }
      )

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

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

        res
      })

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

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

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

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

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

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

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

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

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

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

  UseMethod("variable_choices")
}

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

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

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

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

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

  key <- intersect(subset, key)

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

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

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

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

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

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

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

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

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

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

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

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

  invisible(x)
}

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

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

#' Help text with available datasets input
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Creates [shiny::helpText()] with the names of available datasets for the
#' current module.
#'
#' @param data_extracts (`list`) of data extracts for single variable.
#'
#' @return `shiny.tag` defining help-text element that can be added to a UI element.
#'
#' @export
#'
datanames_input <- function(data_extracts) {
  datanames <- get_extract_datanames(data_extracts)
  helpText(
    paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
    tags$code(paste(datanames, collapse = ", "))
  )
}

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

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

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

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

  unique(unlist(datanames))
}

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

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

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

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

  dplyr_call_data <- get_dplyr_call_data(merged_selector_list, join_keys)

  validate_keys_sufficient(join_keys, merged_selector_list)

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

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

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

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

  all_calls_expression <- c(dplyr_calls, anl_merge_calls, anl_relabel_call)

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

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

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

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

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

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


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

  list(res_list, res_map_id)
}


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

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

  TRUE
}

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

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

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

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

  all(datasets_pairs_keys_present)
}

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

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


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

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

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

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

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

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

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

    anl_merge_calls <- append(
      anl_merge_calls,
      anl_merge_call_i
    )
  }

  anl_merge_calls
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

  relabel_and_assign_call
}

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

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

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

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

  ns <- NS(id)

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

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

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

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

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

      observeEvent(
        input$col,
        ignoreInit = TRUE, # When observeEvent is initialized input$col is still NULL as it is set few lines above
        ignoreNULL = FALSE, # columns could be NULL, then vals should be set to NULL also
        handlerExpr = {
          if (!rlang::is_empty(input$col)) {
            choices <- value_choices(
              datasets[[filter$dataname]](),
              input$col,
              `if`(isTRUE(input$col == attr(filter$choices, "var_choices")), attr(filter$choices, "var_label"), NULL)
            )

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

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

#' Returns the initial values for the `vals` widget of a `filter_spec` object
#'
#' @inheritParams data_extract_filter_srv
#'
#' @return named `list` with two slots `choices` and `selected`.
#'
#' @keywords internal
#'
get_initial_filter_values <- function(filter, datasets) {
  initial_values <- list()
  if (is.null(filter$vars_selected)) {
    initial_values$choices <- character(0)
    initial_values$selected <- character(0)
  } else if (is.null(filter$choices)) {
    initial_values$choices <- value_choices(
      datasets[[filter$dataname]](),
      as.character(filter$vars_selected)
    )
    initial_values$selected <- if (inherits(filter$selected, "all_choices")) {
      initial_values$choices
    } else {
      filter$selected
    }
  } else {
    initial_values$choices <- filter$choices
    initial_values$selected <- filter$selected
  }

  initial_values
}

#' Formatting data extracts
#'
#' Returns a human-readable string representation of an extracted `data_extract_spec` object.
#'
#' This function formats the output of [`data_extract_srv`].
#' See the example for more information.
#'
#' @param data_extract `list` the list output of `data_extract_srv`.

#' @return `character(1)` representation of the `data_extract` object.
#'
#' @examples
#' library(shiny)
#'
#' simple_des <- data_extract_spec(
#'   dataname = "iris",
#'   filter = filter_spec(vars = "Petal.Length", choices = c("1.4", "1.5")),
#'   select = select_spec(choices = c("Petal.Length", "Species"))
#' )
#'
#' ui <- fluidPage(
#'   data_extract_ui(
#'     id = "extract",
#'     label = "data extract ui",
#'     data_extract_spec = simple_des,
#'     is_single_dataset = TRUE
#'   ),
#'   verbatimTextOutput("formatted_extract")
#' )
#' server <- function(input, output, session) {
#'   extracted_input <- data_extract_srv(
#'     id = "extract",
#'     datasets = list(iris = iris),
#'     data_extract_spec = simple_des
#'   )
#'   output$formatted_extract <- renderPrint({
#'     cat(format_data_extract(extracted_input()))
#'   })
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
format_data_extract <- function(data_extract) {
  if (is.null(data_extract)) {
    return(NULL)
  }

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

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

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

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

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

#' Split by separator (matched exactly)
#'
#' `r lifecycle::badge("stable")`
#'
#' @param x (`character`) Character vector, each element of which is to be split.
#' Other inputs, including a factor return themselves.
#' @param sep (`character`) separator to use for splitting.
#'
#' @return List of character vectors split by `sep`. Self if `x` is not a `character`.
#'
#' @export
#'
split_by_sep <- function(x, sep) {
  checkmate::assert_atomic(x)
  if (is.character(x)) {
    strsplit(x, sep, fixed = TRUE)
  } else {
    x
  }
}

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

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

  res
}

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

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

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

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

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

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

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

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

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

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 <- teal.data::rADSL
#' choices_selected(variable_choices(ADSL), "SEX")
#'
#' # How to select nothing
#' # use an empty character
#' choices_selected(
#'   choices = c("", "A", "B", "C"),
#'   selected = ""
#' )
#'
#' # How to allow the user to select nothing
#' # use an empty character
#' choices_selected(
#'   choices = c("A", "", "B", "C"),
#'   selected = "A"
#' )
#'
#'
#' # How to make Nothing the Xth choice
#' # just use keep_order
#' choices_selected(
#'   choices = c("A", "", "B", "C"),
#'   selected = "A",
#'   keep_order = TRUE
#' )
#'
#'
#' # How to give labels to selections
#' # by adding names - choices will be replaced by "name" in UI, not in code
#' choices_selected(
#'   choices = c("name for A" = "A", "Name for nothing" = "", "name for b" = "B", "name for C" = "C"),
#'   selected = "A"
#' )
#'
#' # by using choices_labeled
#' # labels will be shown behind the choice
#' choices_selected(
#'   choices = choices_labeled(
#'     c("A", "", "B", "C"),
#'     c("name for A", "nothing", "name for B", "name for C")
#'   ),
#'   selected = "A"
#' )
#'
#' # Passing a `delayed_data` object to `selected`
#' choices_selected(
#'   choices = variable_choices("ADSL"),
#'   selected = variable_choices("ADSL", subset = c("STUDYID"))
#' )
#'
#' # functional form (subsetting for factor variables only) of choices_selected
#' # with delayed data loading
#' choices_selected(variable_choices("ADSL", subset = function(data) {
#'   idx <- vapply(data, is.factor, logical(1))
#'   names(data)[idx]
#' }))
#'
#' cs <- choices_selected(
#'   choices = c("A", "B", "C"),
#'   selected = "A"
#' )
#'
#' ui <- fluidPage(
#'   optionalSelectInput(
#'     inputId = "id",
#'     choices = cs$choices,
#'     selected = cs$selected
#'   )
#' )
#'
#' server <- function(input, output, session) {}
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#' @export
#'
choices_selected <- function(choices,
                             selected = if (inherits(choices, "delayed_data")) NULL else choices[1],
                             keep_order = FALSE,
                             fixed = FALSE) {
  checkmate::assert(
    checkmate::check_atomic(choices),
    checkmate::check_class(choices, "delayed_data")
  )
  checkmate::assert(
    checkmate::check_atomic(selected),
    checkmate::check_multi_class(selected, c("delayed_data", "all_choices"))
  )
  checkmate::assert_flag(keep_order)
  checkmate::assert_flag(fixed)

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

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

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

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

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

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

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

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

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

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

    x
  }
}

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

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

  vec_attrs <- attributes(vec)

  vec <- vec[idx]

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

  attributes(vec) <- vec_attrs
  vec
}

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

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

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

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

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

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

  idx <- which(duplicated(vec))

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

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

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

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

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

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

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

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

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

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

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

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

#' @describeIn resolve_delayed Default values for `keys` parameters is extracted from `datasets`.
#' @export
resolve_delayed.FilteredData <- function(x,
                                         datasets,
                                         keys = sapply(datasets$datanames(), datasets$get_keys, simplify = FALSE)) {
  datasets_list <- sapply(X = datasets$datanames(), simplify = FALSE, FUN = function(x) {
    reactive(datasets$get_data(dataname = x, filtered = TRUE))
  })
  resolve(x, datasets_list, keys)
}

#' @describeIn resolve_delayed Generic method when `datasets` argument is a named list.
#' @export
resolve_delayed.list <- function(x, datasets, keys = NULL) {
  checkmate::assert_list(datasets, types = c("reactive", "data.frame"), min.len = 1, names = "named")
  checkmate::assert_list(keys, "character", names = "named", null.ok = TRUE)
  checkmate::assert(
    .var.name = "keys",
    checkmate::check_names(names(keys), subset.of = names(datasets)),
    checkmate::check_null(keys)
  )
  # convert to list of reactives
  datasets_list <- sapply(X = datasets, simplify = FALSE, FUN = function(x) {
    if (is.reactive(x)) x else reactive(x)
  })
  resolve(x, datasets_list, keys)
}

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

#' Check selector filters element
#'
#' @param filters (`list`) selector element generated by `data_extract_srv`.
#'
#' @return Raises an error when the check fails, otherwise it returns `NULL`, invisibly.
#'
#' @keywords internal
#'
check_selector_filters <- function(filters) {
  check_selector_filter <- function(x) {
    is.list(x) &&
      all(c("columns", "selected") %in% names(x)) &&
      checkmate::test_character(x$columns, null.ok = TRUE, min.len = 1, any.missing = FALSE) &&
      (
        is.null(x$selected) ||
          all(vapply(x$selected, is.character, logical(1))) ||
          all(vapply(x$selected, is.numeric, logical(1)))
      )
  }
  stopifnot(is.null(filters) || all(vapply(filters, check_selector_filter, logical(1))))
}

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

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

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

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

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

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

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

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

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

  do.call("tagList", res)
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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