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

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

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,":=")

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
 }

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
 }

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

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

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

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