Closes #91 length attribute from max data length

NAMESPACE

@@ -5,6 +5,7 @@ export(length_log)
 export(type_log)
 export(var_names_log)
 export(var_ord_msg)
+export(variable_max_length)
 export(xportr_df_label)
 export(xportr_format)
 export(xportr_label)

R/length.R

@@ -1,16 +1,22 @@
 #' Assign SAS Length
 #'
-#' Assigns SAS length from a metadata object to a given data frame. If a
-#' length isn't present for a variable the length value is set to 200 for
-#' character columns, and 8 for non-character columns. This value is stored in
-#' the 'width' attribute of the column.
+#' 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 200 for character columns, and 8
+#' for non-character columns. This value is stored in the 'width' attribute of the column.
 #'
 #' @param .df A data frame of CDISC standard.
 #' @param metadata A data frame containing variable level metadata. See
 #'   'Metadata' section for details.
 #' @param domain Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset
-#'   the metadata object. If none is passed, then  [xportr_metadata()] must be
-#'   called before hand to set the domain as an attribute of `.df`.
+#'   the metadata object. If none is passed, then name of the dataset passed as
+#'   .df will be used.
+#' @param length 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"`
 #' @param verbose The action this function takes when an action is taken on the
 #'   dataset or function validation finds an issue. See 'Messaging' section for
 #'   details. Options are 'stop', 'warn', 'message', and 'none'
@@ -66,6 +72,7 @@
 xportr_length <- function(.df,
                           metadata = NULL,
                           domain = NULL,
+                          length = "metadata",
                           verbose = getOption("xportr.length_verbose", "none"),
                           metacore = deprecated()) {
   if (!missing(metacore)) {
@@ -109,17 +116,37 @@ xportr_length <- function(.df,
 
   length_log(miss_vars, verbose)
 
-  length <- metadata[[variable_length]]
-  names(length) <- metadata[[variable_name]]
+  if (length == "metadata") {
+    length_metadata <- metadata[[variable_length]]
+    names(length_metadata) <- metadata[[variable_name]]
+
+    for (i in names(.df)) {
+      if (i %in% miss_vars) {
+        attr(.df[[i]], "width") <- impute_length(.df[[i]])
+      } else {
+        attr(.df[[i]], "width") <- length_metadata[[i]]
+      }
+    }
+  }
+
+  # Assign length from data
+  if (length == "data") {
+    var_length_max <- variable_max_length(.df)
+
+    length_data <- var_length_max[[variable_length]]
+    names(length_data) <- var_length_max[[variable_name]]
 
-  for (i in names(.df)) {
-    if (i %in% miss_vars) {
-      attr(.df[[i]], "width") <- impute_length(.df[[i]])
-    } else {
-      attr(.df[[i]], "width") <- length[[i]]
+    for (i in names(.df)) {
+      attr(.df[[i]], "width") <- length_data[[i]]
     }
+
+    length_msg <- left_join(var_length_max, metadata[, c(variable_name, variable_length)], by = variable_name) %>%
+      filter(length.x < length.y)
+
+    max_length_msg(length_msg, verbose)
   }
 
+
   .df
 }
 

R/messages.R

@@ -181,3 +181,31 @@ var_ord_msg <- function(reordered_vars, moved_vars, verbose) {
     cli_h2("All variables in dataset are ordered")
   }
 }
+
+#' Utility for data Lengths
+#'
+#' @param max_length Dataframe with data and metadata length
+#' @param verbose Provides additional messaging for user
+#'
+#' @return Output to Console
+
+max_length_msg <- function(max_length, verbose) {
+  if (nrow(max_length) > 0) {
+    cli_h2("Variable length is shorter than the length specified in the metadata.")
+
+    xportr_logger(
+      glue(
+        "Update length in metadata to trim the variables:"
+      ),
+      type = verbose
+    )
+
+    xportr_logger(
+      glue(
+        "{format(max_length[[1]], width = 8)} has a length of {format(as.character(max_length[[2]]), width = 3)}",
+        " and a length of {format(as.character(max_length[[3]]), width = 3)} in metadata"
+      ),
+      type = verbose
+    )
+  }
+}

R/utils-xportr.R

@@ -307,7 +307,7 @@
 
   # 4.0 max length of Character variables <= 200 bytes
   max_nchar <- data %>%
-    summarize(across(where(is.character), ~ max(nchar(., type = "bytes"))))
+    summarize(across(where(is.character), ~ max(0L, nchar(., type = "bytes"), na.rm = TRUE)))
   nchar_gt_200 <- max_nchar[which(max_nchar > 200)]
   if (length(nchar_gt_200) > 0) {
     err_cnd <- c(
@@ -372,6 +372,42 @@
   }
 }
 
+
+#' Calculate the maximum length of variables
+#'
+#' Function to calculate the maximum length of variables in a given dataframe
+#'
+#' @inheritParams xportr_length
+#'
+#' @return Returns a dataframe with variables and their maximum length
+#'
+#' @export
+
+variable_max_length <- function(.df) {
+  variable_length <- getOption("xportr.length")
+  variable_name <- getOption("xportr.variable_name")
+
+  max_nchar <- .df %>%
+    summarize(across(where(is.character), ~ max(0L, nchar(., type = "bytes"), na.rm = TRUE)))
+
+
+  xport_max_length <- data.frame()
+  col <- 0
+  for (var in names(.df)) {
+    col <- col + 1
+
+    xport_max_length[col, variable_name] <- var
+
+    if (is.character(.df[[var]])) {
+      xport_max_length[col, variable_length] <- max_nchar[var]
+    } else {
+      xport_max_length[col, variable_length] <- 8
+    }
+  }
+
+  return(xport_max_length)
+}
+
 #' Custom check for metadata object
 #'
 #' Improvement on the message clarity over the default assert(...) messages.
@@ -421,3 +457,4 @@
 #' Internal choices for verbose option
 #' @noRd
 .internal_verbose_choices <- c("none", "warn", "message", "stop")
+

tests/testthat/test-length.R

@@ -193,6 +193,32 @@ test_that("xportr_length: Gets warning when metadata has multiple rows with same
   multiple_vars_in_spec_helper2(xportr_length)
 })
 
+meta_example <- data.frame(
+  dataset = "df",
+  variable = c("USUBJID", "WEIGHT"),
+  length = c(10, 8)
+)
+
+df <- data.frame(
+  USUBJID = c("1", "12", "123"),
+  WEIGHT = c(85, 45, 121)
+)
+
+test_that("xportr_length: length assigned as expected from metadata or data", {
+  result <- df %>%
+    xportr_length(meta_example, domain = "df", length = "metadata") %>%
+    expect_attr_width(c(10, 8))
+
+  result <- df %>%
+    xportr_length(meta_example, domain = "df", length = "data") %>%
+    expect_attr_width(c(3, 8))
+})
+
+test_that("xportr_length: Gets message when length in metadata longer than data length", {
+  result <- df %>%
+    xportr_length(meta_example, domain = "df", length = "data") %>%
+    expect_message()
+})
 
 test_that("xportr_length: Works as expected with only one domain in metadata", {
   adsl <- data.frame(

tests/testthat/test-utils-xportr.R

@@ -127,3 +127,11 @@ test_that("xpt_validate: Get error message when the length of a non-ASCII charac
     "Length of A must be 200 bytes or less."
   )
 })
+
+test_that("xpt_validate: Get error message when the length of a character variable is > 200 bytes and contains NAs", {
+  df <- data.frame(A = c(paste(rep("A", 201), collapse = ""), NA_character_))
+  expect_equal(
+    xpt_validate(df),
+    "Length of A must be 200 bytes or less."
+  )
+})