Closes #244 #251 reduces cyclomatic complexity and cleanup of .lintr (

#254) * chore: reduce cyclomatic complexity * chore: remove extra lintr rules * fix: force numeric width attribute * lintr: reduce complexity and improve lintr rules * lintr: allows object_usage linter with specific exception for glue * chore: revert import of deprecate_stop * chore: use integer for vapply template * lintr: rename argument of internal function * chore: missed 1 deprecated_stop in regression * lintr: remove exception no longer necessary * feat: remove repeated $ * chore: remove extra empty line * lintr: revert to disable object_usage * fix: remove space * chore: removes unused import
atorus-research · Mar 4, 2024 · 1bb339a · 1bb339a
1 parent 5fea973
commit 1bb339a
Show file tree

Hide file tree

Showing 10 changed files with 77 additions and 69 deletions.
diff --git a/.lintr b/.lintr
@@ -1,9 +1,13 @@
 linters: linters_with_defaults(
-  cyclocomp_linter(complexity_limit = 25),
   line_length_linter(120),
   object_usage_linter = NULL,
-  object_name_linter = NULL,
-  trailing_whitespace_linter(allow_empty_lines = TRUE, allow_in_strings = TRUE)
+  object_name_linter = object_name_linter(
+    styles = c("snake_case", "symbols"),
+    regexes = c(
+      xportr_attr = "^_xportr\\.[a-z_]+_$", # Attribute names used in xportr
+      ADaM = "^AD[A-Z]{2,3}$" # Supports CDISC ADaM standard for non-sponsored datasets
+    )
+  )
   )
 encoding: "UTF-8"
 exclusions: list()
diff --git a/NAMESPACE b/NAMESPACE
@@ -65,7 +65,6 @@ importFrom(purrr,map_chr)
 importFrom(purrr,map_dbl)
 importFrom(purrr,pluck)
 importFrom(purrr,walk)
-importFrom(purrr,walk2)
 importFrom(readr,parse_number)
 importFrom(rlang,"%||%")
 importFrom(rlang,":=")

diff --git a/R/format.R b/R/format.R
@@ -140,7 +140,7 @@ xportr_format <- function(.df,
 
   if (domain_name %in% names(metadata) && !is.null(domain)) {
     metadata <- metadata %>%
-      dplyr::filter(!!sym(domain_name) == domain & !is.na(!!sym(format_name)))
+      filter(!!sym(domain_name) == domain & !is.na(!!sym(format_name)))
   } else {
     # Common check for multiple variables name
     check_multiple_var_specs(metadata, variable_name)
@@ -156,6 +156,12 @@ xportr_format <- function(.df,
 
   names(format) <- filtered_metadata[[variable_name]]
 
+  # Returns modified .df
+  check_formats(.df, format, verbose)
+}
+
+# Internal function to check formats
+check_formats <- function(.df, format, verbose) {
   # vector of expected formats for clinical trials (usually character or date/time)
   # https://documentation.sas.com/doc/en/pgmsascdc/9.4_3.5/leforinforref
   # /n0p2fmevfgj470n17h4k9f27qjag.htm#n0wi06aq4kydlxn1uqc0p6eygu75
@@ -165,26 +171,25 @@ xportr_format <- function(.df,
   # w.d format for numeric variables
   format_regex <- .internal_format_regex
 
-
   for (i in seq_len(ncol(.df))) {
-    format_sas <- purrr::pluck(format, colnames(.df)[i])
-    if (is.na(format_sas) || is.null(format_sas)) {
-      format_sas <- ""
-    }
+    format_sas <- pluck(format, colnames(.df)[i], .default = "")
+    format_sas[is.na(format_sas)] <- ""
+
     # series of checks for formats
 
     # check that any variables ending DT, DTM, TM have a format
-    if (isTRUE(grepl("DT$|DTM$|TM$", colnames(.df)[i])) && format_sas == "") {
-      message <- glue(
-        "(xportr::xportr_format) {encode_vars(colnames(.df)[i])} is expected to have a format but does not."
-      )
-      xportr_logger(message, type = verbose)
-    }
+    if (identical(format_sas, "")) {
+      if (isTRUE(grepl("(DT|DTM|TM)$", colnames(.df)[i]))) {
+        message <- glue(
+          "(xportr::xportr_format) {encode_vars(colnames(.df)[i])} is expected to have a format but does not."
+        )
+        xportr_logger(message, type = verbose)
+      }
+    } else {
+      # remaining checks to be carried out if a format exists
 
-    # remaining checks to be carried out if a format exists
-    if (format_sas != "") {
       # if the variable is character
-      if (class(.df[[i]])[1] == "character") {
+      if (is.character(.df[[i]])) {
         # character variable formats should start with a $
         if (isFALSE(grepl("^\\$", format_sas))) {
           message <- glue(
@@ -195,7 +200,7 @@ xportr_format <- function(.df,
           xportr_logger(message, type = verbose)
         }
         # character variable formats should have length <= 31 (excluding the $)
-        if (nchar(gsub("\\.$", "", format_sas)) > 32) {
+        if (nchar(gsub("[.]$", "", format_sas)) > 32) {
           message <- glue(
             "(xportr::xportr_format)",
             " Format for character variable {encode_vars(colnames(.df)[i])}",
@@ -206,7 +211,7 @@ xportr_format <- function(.df,
       }
 
       # if the variable is numeric
-      if (class(.df[[i]])[1] == "numeric") {
+      if (is.numeric(.df[[i]])) {
         # numeric variables should not start with a $
         if (isTRUE(grepl("^\\$", format_sas))) {
           message <- glue(
@@ -229,8 +234,8 @@ xportr_format <- function(.df,
 
       # check if the format is either one of the expected formats or follows the regular expression for w.d format
       if (
-        !(format_sas %in% toupper(expected_formats)) &&
-          (stringr::str_detect(format_sas, pattern = format_regex) == FALSE)
+        isFALSE(format_sas %in% toupper(expected_formats)) &&
+          isFALSE(str_detect(format_sas, pattern = format_regex))
       ) {
         message <- glue(
           "(xportr::xportr_format)",
@@ -243,6 +248,5 @@ xportr_format <- function(.df,
 
     attr(.df[[i]], "format.sas") <- format_sas
   }
-
   .df
 }
diff --git a/R/length.R b/R/length.R
@@ -121,35 +121,27 @@ xportr_length <- function(.df,
   # Check any variables missed in metadata but present in input data ---
   miss_vars <- setdiff(names(.df), metadata[[variable_name]])
 
-  miss_length <- as.character()
-  if (length_source == "metadata") {
+  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)])
 
-    for (i in names(.df)) {
-      if (i %in% miss_vars) {
-        attr(.df[[i]], "width") <- length_data[[i]]
-      } else if (is.na(length_metadata[[i]])) {
-        attr(.df[[i]], "width") <- length_data[[i]]
-      } else {
-        attr(.df[[i]], "width") <- length_metadata[[i]]
-      }
-    }
-  }
-
-  # Message for missing var and missing length
-  length_log(miss_vars, miss_length, verbose)
-
-  # Assign length from data
-  if (length_source == "data") {
-    for (i in names(.df)) {
-      attr(.df[[i]], "width") <- length_data[[i]]
-    }
-
-
+    # 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(
@@ -160,7 +152,17 @@ xportr_length <- function(.df,
       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)
+
   .df
 }
diff --git a/R/support-test.R b/R/support-test.R
@@ -136,7 +136,7 @@ local_cli_theme <- function(.local_envir = parent.frame()) {
 
 #' Test if multiple vars in spec will result in warning message
 #' @keywords internal
-multiple_vars_in_spec_helper <- function(FUN) {
+multiple_vars_in_spec_helper <- function(fun) {
   adsl <- minimal_table(30)
   metadata <- minimal_metadata(
     dataset = TRUE,
@@ -158,13 +158,13 @@ multiple_vars_in_spec_helper <- function(FUN) {
   local_cli_theme()
 
   adsl %>%
-    FUN(metadata, "adsl") %>%
+    fun(metadata, "adsl") %>%
     testthat::expect_message("There are multiple specs for the same variable name")
 }
 
 #' Test if multiple vars in spec with appropriate
 #' @keywords internal
-multiple_vars_in_spec_helper2 <- function(FUN) {
+multiple_vars_in_spec_helper2 <- function(fun) {
   adsl <- minimal_table(30)
   metadata <- minimal_metadata(
     dataset = TRUE,
@@ -187,6 +187,6 @@ multiple_vars_in_spec_helper2 <- function(FUN) {
 
   adsl %>%
     xportr_metadata(domain = "adsl") %>%
-    FUN(metadata, "adsl") %>%
+    fun(metadata, "adsl") %>%
     testthat::expect_no_message(message = "There are multiple specs for the same variable name")
 }
diff --git a/R/type.R b/R/type.R
@@ -104,10 +104,10 @@ xportr_type <- function(.df,
   domain_name <- getOption("xportr.domain_name")
   variable_name <- getOption("xportr.variable_name")
   type_name <- getOption("xportr.type_name")
-  characterTypes <- c(getOption("xportr.character_types"), "_character")
-  characterMetadataTypes <- c(getOption("xportr.character_metadata_types"), "_character")
-  numericMetadataTypes <- c(getOption("xportr.numeric_metadata_types"), "_numeric")
-  numericTypes <- c(getOption("xportr.numeric_types"), "_numeric")
+  character_types <- c(getOption("xportr.character_types"), "_character")
+  character_metadata_types <- c(getOption("xportr.character_metadata_types"), "_character")
+  numeric_metadata_types <- c(getOption("xportr.numeric_metadata_types"), "_numeric")
+  numeric_types <- c(getOption("xportr.numeric_types"), "_numeric")
 
   if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec
 
@@ -134,15 +134,15 @@ xportr_type <- function(.df,
     mutate(
       # _character is used here as a mask of character, in case someone doesn't
       # want 'character' coerced to character
-      type.x = if_else(type.x %in% characterTypes, "_character", type.x),
-      type.x = if_else(type.x %in% numericTypes,
+      type.x = if_else(type.x %in% character_types, "_character", type.x),
+      type.x = if_else(type.x %in% numeric_types,
         "_numeric",
         type.x
       ),
       type.y = if_else(is.na(type.y), type.x, type.y),
       type.y = tolower(type.y),
-      type.y = if_else(type.y %in% characterMetadataTypes, "_character", type.y),
-      type.y = if_else(type.y %in% numericMetadataTypes, "_numeric", type.y)
+      type.y = if_else(type.y %in% character_metadata_types, "_character", type.y),
+      type.y = if_else(type.y %in% numeric_metadata_types, "_numeric", type.y)
     )
 
   # It is possible that a variable exists in the table that isn't in the metadata
@@ -166,7 +166,7 @@ xportr_type <- function(.df,
         orig_attributes <- attributes(.df[[i]])
         orig_attributes$class <- NULL
         orig_attributes$levels <- NULL
-        if (correct_type[i] %in% characterTypes) {
+        if (correct_type[i] %in% character_types) {
           .df[[i]] <<- as.character(.df[[i]])
         } else {
           .df[[i]] <<- as.numeric(.df[[i]])

diff --git a/R/utils-xportr.R b/R/utils-xportr.R
@@ -331,9 +331,9 @@ get_pipe_call <- function() {
 #' @return "character" or class of vector
 #' @noRd
 first_class <- function(x) {
-  characterTypes <- getOption("xportr.character_types")
+  character_types <- getOption("xportr.character_types")
   class_ <- tolower(class(x)[1])
-  if (class_ %in% characterTypes) {
+  if (class_ %in% character_types) {
     "character"
   } else {
     class_
@@ -410,7 +410,7 @@ variable_max_length <- function(.df) {
 #' @param metadata A data frame or `Metacore` object containing variable level
 #' @inheritParams checkmate::check_logical
 #' metadata.
-check_metadata <- function(metadata, include_fun_message, null.ok = FALSE) {
+check_metadata <- function(metadata, include_fun_message, null.ok = FALSE) { # nolint: object_name.
   if (is.null(metadata) && null.ok) {
     return(TRUE)
   }
@@ -438,9 +438,9 @@ check_metadata <- function(metadata, include_fun_message, null.ok = FALSE) {
 #' metadata.
 assert_metadata <- function(metadata,
                             include_fun_message = TRUE,
-                            null.ok = FALSE,
+                            null.ok = FALSE, # nolint: object_name.
                             add = NULL,
-                            .var.name = vname(metadata)) {
+                            .var.name = vname(metadata)) { # nolint: object_name.
   makeAssertion(
     metadata,
     check_metadata(metadata, include_fun_message, null.ok),

diff --git a/R/xportr-package.R b/R/xportr-package.R
@@ -101,6 +101,7 @@
 #' @keywords internal
 #' @aliases xportr-package
 #'
+#' @importFrom lifecycle deprecated
 #' @importFrom haven write_xpt
 #' @importFrom rlang abort warn inform with_options local_options .data := sym
 #'   %||%
@@ -114,7 +115,6 @@
 #' @importFrom utils capture.output str tail packageVersion
 #' @importFrom stringr str_detect str_extract str_replace str_replace_all
 #' @importFrom readr parse_number
-#' @importFrom purrr map_chr map2_chr walk walk2 map map_dbl pluck
 #' @importFrom purrr map_chr map2_chr walk iwalk map map_dbl pluck
 #' @importFrom graphics stem
 #' @importFrom magrittr %>% extract2
@@ -133,6 +133,5 @@ globalVariables(c(
 # The following block is used by usethis to automatically manage
 # roxygen namespace tags. Modify with care!
 ## usethis namespace: start
-#' @importFrom lifecycle deprecated
 ## usethis namespace: end
 NULL
diff --git a/man/multiple_vars_in_spec_helper.Rd b/man/multiple_vars_in_spec_helper.Rd
diff --git a/man/multiple_vars_in_spec_helper2.Rd b/man/multiple_vars_in_spec_helper2.Rd