R/length.R

In xportr: Utilities to Output CDISC SDTM/ADaM XPT Files

#' Assign SAS Length
#'
#' Assigns the SAS length to a specified data frame, either from a metadata object
#' or based on the calculated maximum data length. If a length isn't present for
#' a variable the length value is set to maximum data length for character columns, and 8
#' for non-character columns. This value is stored in the 'width' attribute of the column.
#'
#' @inheritParams xportr
#' @param metadata A metacore object or a data frame containing variable level metadata. See
#'   'Metadata' section for details.
#' @param length_source Choose the assigned length from either metadata or data.
#'
#'   If `"metadata"` is specified, the assigned length is from the metadata length.
#'   If `"data"` is specified, the assigned length is determined by the calculated maximum data length.
#'
#'   *Permitted Values*: `"metadata"`, `"data"`
#'
#' @section Messaging: If there are any columns present in the '.df' that are not
#'   noted in the metadata, or any variables in metadata that have missing length
#'   values, their length is set to maximum data length for character columns, and
#'   8 for non-character columns. A message will be generated noting the number
#'   of those variables.
#'
#'   If there are variables in the metadata that don't exist in '.df', they will
#'   be skipped and a message will be generated noting the number of metadata variables
#'   skipped.
#'
#'   In both cases, if the value passed to the 'verbose' argument is 'stop', 'warn',
#'   or 'message', a complete list of the affected variables will be provided.
#'
#' @section Metadata: The argument passed in the 'metadata' argument can either
#'   be a metacore object, or a data.frame containing the data listed below. If
#'   metacore is used, no changes to options are required.
#'
#'   For data.frame 'metadata' arguments three columns must be present:
#'
#'   1) Domain Name - passed as the 'xportr.domain_name' option. Default:
#'   "dataset". This is the column subset by the 'domain' argument in the
#'   function.
#'
#'   2) Variable Name - passed as the 'xportr.variable_name' option.
#'   Default: "variable". This is used to match columns in '.df' argument and
#'   the metadata.
#'
#'   3) Variable Label - passed as the 'xportr.length' option.
#'   Default: "length". These numeric values to update the 'width' attribute of
#'   the column. This is passed to `haven::write_xpt` to note the variable length.
#'
#'
#' @return Data frame with SAS default length attributes for each variable.
#'
#' @export
#'
#' @examples
#' adsl <- data.frame(
#'   USUBJID = c(1001, 1002, 1003),
#'   BRTHDT = c(1, 1, 2)
#' )
#'
#' metadata <- data.frame(
#'   dataset = c("adsl", "adsl"),
#'   variable = c("USUBJID", "BRTHDT"),
#'   length = c(10, 8)
#' )
#'
#' adsl <- xportr_length(adsl, metadata, domain = "adsl", length_source = "metadata")
xportr_length <- function(.df,
                          metadata = NULL,
                          domain = NULL,
                          verbose = NULL,
                          length_source = c("metadata", "data")) {
  length_source <- match.arg(length_source)

  ## Common section to detect default arguments

  domain <- domain %||% attr(.df, "_xportr.df_arg_")
  if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain

  metadata <- metadata %||% attr(.df, "_xportr.df_metadata_")

  # Verbose should use an explicit verbose option first, then the value set in
  # metadata, and finally fall back to the option value
  verbose <- verbose %||%
    attr(.df, "_xportr.df_verbose_") %||%
    getOption("xportr.length_verbose", "none")
  ## End of common section

  assert_data_frame(.df)
  assert_string(domain, null.ok = TRUE)
  assert_metadata(metadata)
  assert_choice(verbose, choices = .internal_verbose_choices)
  .df <- group_data_check(.df, verbose = verbose)

  domain_name <- getOption("xportr.domain_name")
  variable_length <- getOption("xportr.length")
  variable_name <- getOption("xportr.variable_name")

  if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec

  if (domain_name %in% names(metadata) && !is.null(domain)) {
    # If 'domain' passed by user isn't found in metadata, return error
    if (!domain %in% metadata[[domain_name]]) log_no_domain(domain, domain_name, verbose)

    metadata <- metadata |>
      filter(!!sym(domain_name) == .env$domain)
  } else {
    # Common check for multiple variables name
    check_multiple_var_specs(metadata, variable_name)
  }

  # Get max length for missing length and when length_source == "data"
  var_length_max <- variable_max_length(.df)

  length_data <- var_length_max[[variable_length]]
  names(length_data) <- var_length_max[[variable_name]]

  # Check any variables missed in metadata but present in input data ---
  miss_vars <- setdiff(names(.df), metadata[[variable_name]])

  # Check any variables missed in input data but present in metadata ---
  miss_meta_vars <- setdiff(metadata[[variable_name]], names(.df))

  miss_length <- character(0L)
  width_attr <- if (identical(length_source, "metadata")) {
    length_metadata <- metadata[[variable_length]]
    names(length_metadata) <- metadata[[variable_name]]

    # Check any variables with missing length in metadata
    miss_length <- names(length_metadata[is.na(length_metadata)])

    # Build `width` attribute
    vapply(
      names(.df),
      function(i) {
        if (i %in% miss_vars || is.na(length_metadata[[i]])) {
          as.numeric(length_data[[i]])
        } else {
          as.numeric(length_metadata[[i]])
        }
      },
      numeric(1L)
    )
  } else if (identical(length_source, "data")) {
    length_msg <- left_join(var_length_max, metadata[, c(variable_name, variable_length)], by = variable_name)
    length_msg <- length_msg |>
      mutate(
        length_df = as.numeric(length_msg[[paste0(variable_length, ".x")]]),
        length_meta = as.numeric(length_msg[[paste0(variable_length, ".y")]])
      ) |>
      filter(.data$length_df < .data$length_meta) |>
      select(any_of(c(variable_name, "length_df", "length_meta")))

    max_length_msg(length_msg, verbose)

    # Build `width` attribute
    length_data[names(.df)]
  }

  for (i in names(.df)) {
    attr(.df[[i]], "width") <- width_attr[[i]]
  }

  # Message for missing var and missing length
  length_log(miss_vars, miss_length, verbose)

  # Message for missing meta var
  metadata_vars_log(miss_meta_vars, verbose)

  .df
}