diff --git a/.lintr b/.lintr index 54dd81ce..775d1428 100644 --- 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 index f06f9044..30a076c0 100644 --- 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 index 199caa77..f0abcca6 100644 --- 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 index b370c541..33a98394 100644 --- 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 index 3adcef8d..29c71dc0 100644 --- 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 index 10d5c97d..d02c3bfa 100644 --- 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 index fd689f06..c4c0658e 100644 --- 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 index fefafe10..ce107099 100644 --- 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 index d3cefce6..6553f5aa 100644 --- a/man/multiple_vars_in_spec_helper.Rd +++ b/man/multiple_vars_in_spec_helper.Rd @@ -4,7 +4,7 @@ \alias{multiple_vars_in_spec_helper} \title{Test if multiple vars in spec will result in warning message} \usage{ -multiple_vars_in_spec_helper(FUN) +multiple_vars_in_spec_helper(fun) } \description{ Test if multiple vars in spec will result in warning message diff --git a/man/multiple_vars_in_spec_helper2.Rd b/man/multiple_vars_in_spec_helper2.Rd index f3e09957..c9b6c471 100644 --- a/man/multiple_vars_in_spec_helper2.Rd +++ b/man/multiple_vars_in_spec_helper2.Rd @@ -4,7 +4,7 @@ \alias{multiple_vars_in_spec_helper2} \title{Test if multiple vars in spec with appropriate} \usage{ -multiple_vars_in_spec_helper2(FUN) +multiple_vars_in_spec_helper2(fun) } \description{ Test if multiple vars in spec with appropriate