From 6276649a116551e25184947f279ce0846ff47af6 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 27 Apr 2023 20:42:04 +0530 Subject: [PATCH 01/26] feat: adding tests and example for xportr_order() --- R/order.R | 15 ++++++ tests/testthat/test-order.R | 101 ++++++++++++++++++++++++++++-------- 2 files changed, 93 insertions(+), 23 deletions(-) diff --git a/R/order.R b/R/order.R index 0b451258..eabc88dd 100644 --- a/R/order.R +++ b/R/order.R @@ -9,6 +9,21 @@ #' @export #' @return Dataframe that has been re-ordered according to spec #' +#' @examples +#' adsl <- data.frame( +#' BRTHDT = c(1, 1, 2), +#' STUDYID = c("mid987650", "mid987650", "mid987650"), +#' TRT01A = c("Active", "Active", "Placebo"), +#' USUBJID = c(1001, 1002, 1003) +#' ) +#' +#' metacore <- data.frame( +#' dataset = c("adsl", "adsl", "adsl", "adsl"), +#' variable = c("STUDYID", "USUBJID", "TRT01A", "BRTHDT"), +#' order = 1:4 +#' ) +#' +#' adsl <- xportr_order(adsl, metacore) xportr_order <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.order_verbose", "none")) { domain_name <- getOption("xportr.domain_name") diff --git a/tests/testthat/test-order.R b/tests/testthat/test-order.R index d249431d..df60f54b 100644 --- a/tests/testthat/test-order.R +++ b/tests/testthat/test-order.R @@ -3,37 +3,92 @@ suppressWarnings({ library(readxl) }) -test_that("Variable are ordered correctly", { +test_that("xportr_order: Variable are ordered correctly for data.frame spec", { + df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) + df_meta <- data.frame( + dataset = "df", + variable = letters[1:4], + order = 1:4 + ) - ADAE <- read_sas(system.file("extdata", "adae.sas7bdat", package = "xportr")) - met <- read_excel(system.file("specs", "ADaM_spec.xlsx", package = "xportr"), 3) + ordered_df <- xportr_order(df, df_meta) + + expect_equal(names(ordered_df), df_meta$variable) +}) + +test_that("xportr_order: Variable are ordered correctly when data is piped", { + df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) + df_meta <- data.frame( + dataset = "df", + variable = letters[1:4], + order = 1:4 + ) + + ordered_df <- df %>% + xportr_order(df_meta) %>% + xportr_order(df_meta) + + expect_equal(names(ordered_df), df_meta$variable) +}) + +test_that("xportr_order: Variable are ordered correctly for custom domain", { + df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) + df_meta <- data.frame( + dataset = "DOMAIN", + variable = letters[1:4], + order = 1:4 + ) - withr::with_options( - list(xportr.order_name = "Order", xportr.variable_name = "Variable"), { - ADAE_xportr <- xportr_order(ADAE, metacore = met, "ADAE", verbose = "none") - } + ordered_df <- xportr_order(df, df_meta, domain = "DOMAIN") + + expect_equal(names(ordered_df), df_meta$variable) +}) + +test_that("xportr_order: Variable are ordered correctly for metacore spec", { + df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) + ordered_columns <- letters[1:4] + metacore_meta <- suppressWarnings( + metacore::metacore( + ds_vars = data.frame( + dataset = "df", + variable = ordered_columns, + keep = TRUE, + key_seq = NA, + order = 1:4, + core = NA_character_, + supp_flag = NA + ) + ) + ) + + ordered_df <- xportr_order(df, metacore_meta) + + expect_equal(names(ordered_df), ordered_columns) +}) + +test_that("xportr_order: Variable are ordered when custom domain_name is passed", { + df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) + df_meta <- data.frame( + custom_domain = "df", + variable = letters[1:4], + order = 1:4 ) - - after_names <- c("STUDYID", "USUBJID", "AEDECOD", "AESOC", "AETERM", "AESER", - "ASTDT", "AENDT", "ATOXGR", "TRT01A", "TRT01AN", "SAFFL", "SUBJID", - "WEIGHTBL", "SEX", "AGE", "AGEU", "RACE", "SITEID", "RACEN", - "ASTTM", "ADURC", "AEACN", "AEOUT", "AEREL", "ATOXGRN", "AFTRTSTC", - "AEWDFL") - - expect_equal(names(ADAE_xportr), after_names) + + ordered_df <- xportr_order(df, df_meta, domain = "df") + + expect_equal(names(ordered_df), df_meta$variable) }) test_that("Domain not in character format", { - ADAE <- read_sas(system.file("extdata", "adae.sas7bdat", package = "xportr")) met <- read_excel(system.file("specs", "ADaM_spec.xlsx", package = "xportr"), 3) - + expect_error( withr::with_options( - list(xportr.order_name = "Order", xportr.variable_name = "Variable"), { - ADAE_xportr <- xportr_order(ADAE, metacore = met, domain = ADAE, verbose = "none") - } - )) - - + list(xportr.order_name = "Order", xportr.variable_name = "Variable"), + { + ADAE_xportr <- xportr_order(ADAE, metacore = met, domain = ADAE, verbose = "none") + } + ) + ) }) From 31808bf94742ab4479e8f9a6cdb950b1e68db342 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 27 Apr 2023 20:46:10 +0530 Subject: [PATCH 02/26] docs: update document with example for xportr_order --- NAMESPACE | 1 + man/xportr_order.Rd | 16 ++++++++++++++++ 2 files changed, 17 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 3a261d6b..90b9880b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ importFrom(cli,cli_alert_success) importFrom(cli,cli_div) importFrom(cli,cli_h2) importFrom(cli,cli_text) +importFrom(dplyr,all_of) importFrom(dplyr,arrange) importFrom(dplyr,bind_cols) importFrom(dplyr,case_when) diff --git a/man/xportr_order.Rd b/man/xportr_order.Rd index e0e9ceec..236862d6 100644 --- a/man/xportr_order.Rd +++ b/man/xportr_order.Rd @@ -27,3 +27,19 @@ Dataframe that has been re-ordered according to spec \description{ Order variables of a dataset according to Spec } +\examples{ +adsl <- data.frame( + BRTHDT = c(1, 1, 2), + STUDYID = c("mid987650", "mid987650", "mid987650"), + TRT01A = c("Active", "Active", "Placebo"), + USUBJID = c(1001, 1002, 1003) +) + +metacore <- data.frame( + dataset = c("adsl", "adsl", "adsl", "adsl"), + variable = c("STUDYID", "USUBJID", "TRT01A", "BRTHDT"), + order = 1:4 +) + +adsl <- xportr_order(adsl, metacore) +} From 547a32a42aa3c0272f193576cac43faea96bef2c Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 27 Apr 2023 20:51:42 +0530 Subject: [PATCH 03/26] chore: update test to be consistent --- tests/testthat/test-order.R | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/tests/testthat/test-order.R b/tests/testthat/test-order.R index df60f54b..64a7d19b 100644 --- a/tests/testthat/test-order.R +++ b/tests/testthat/test-order.R @@ -79,16 +79,14 @@ test_that("xportr_order: Variable are ordered when custom domain_name is passed" expect_equal(names(ordered_df), df_meta$variable) }) -test_that("Domain not in character format", { - ADAE <- read_sas(system.file("extdata", "adae.sas7bdat", package = "xportr")) - met <- read_excel(system.file("specs", "ADaM_spec.xlsx", package = "xportr"), 3) - - expect_error( - withr::with_options( - list(xportr.order_name = "Order", xportr.variable_name = "Variable"), - { - ADAE_xportr <- xportr_order(ADAE, metacore = met, domain = ADAE, verbose = "none") - } - ) +test_that("xportr_order: Expect error if domain is not a character", { + df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) + df_meta <- data.frame( + custom_domain = "df", + variable = letters[1:4], + order = 1:4 ) + + expect_error(xportr_order(df, df_meta, domain = NA, verbose = "none")) + expect_error(xportr_order(df, df_meta, domain = 1, verbose = "none")) }) From aa60e2a89acaaff8cde761046fb199eb31617d28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 26 Apr 2023 11:41:07 +0200 Subject: [PATCH 04/26] adds test --- tests/testthat/test-pipe.R | 60 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) create mode 100644 tests/testthat/test-pipe.R diff --git a/tests/testthat/test-pipe.R b/tests/testthat/test-pipe.R new file mode 100644 index 00000000..ee214ce3 --- /dev/null +++ b/tests/testthat/test-pipe.R @@ -0,0 +1,60 @@ +test_that("xportr_*: Can use magrittr to pipe", { + adsl <- dplyr::tibble( + USUBJID = c(1001, 1002, 1003), + SITEID = c(001, 002, 003), + ADATE = readr::parse_date(c("2023-04-11", "2023-04-12", "2023-04-13")), + AGE = c(63, 35, 27), + SEX = c("M", "F", "M") + ) + + metadata <- dplyr::tibble( + dataset = "adsl", + variable = c("USUBJID", "SITEID", "ADATE", "AGE", "SEX"), + label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"), + type = c("character", "character", "character", "numeric", "character"), + length = c(10, 10, 10, 8, 10), + format = c(NA, NA, "DATE9.", NA, NA) + ) + + result <- adsl %>% + xportr_type(metadata) %>% + xportr_label(metadata) %>% + xportr_length(metadata) %>% + xportr_format(metadata) + + attr(result, "_xportr.df_arg_") %>% + expect_equal("adsl") +}) + +test_that("xportr_*: Can use R native pipe (R>4.1)", { + skip_if( + compareVersion(glue("{R.version$major}.{R.version$minor}"), "4.1.0") < 0, + "R Version doesn't support native pipe (<4.1)" + ) + + adsl <- dplyr::tibble( + USUBJID = c(1001, 1002, 1003), + SITEID = c(001, 002, 003), + ADATE = readr::parse_date(c("2023-04-11", "2023-04-12", "2023-04-13")), + AGE = c(63, 35, 27), + SEX = c("M", "F", "M") + ) + + metadata <- dplyr::tibble( + dataset = "adsl", + variable = c("USUBJID", "SITEID", "ADATE", "AGE", "SEX"), + label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"), + type = c("character", "character", "character", "numeric", "character"), + length = c(10, 10, 10, 8, 10), + format = c(NA, NA, "DATE9.", NA, NA) + ) + + result <- adsl |> + xportr_type(metadata) |> + xportr_label(metadata) |> + xportr_length(metadata) |> + xportr_format(metadata) + + attr(result, "_xportr.df_arg_") %>% + expect_equal("adsl") +}) From 1a351515beed8c99ac3bb6c738ac390153d1299b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 15:27:53 +0200 Subject: [PATCH 05/26] corrects bug on #97 --- R/df_label.R | 42 ++++++----------- R/format.R | 41 ++++++---------- R/label.R | 44 +++++++----------- R/length.R | 22 +++------ R/order.R | 49 ++++++++------------ R/type.R | 40 ++++++---------- R/utils-xportr.R | 73 ++++++++++++++++++----------- tests/testthat/test-metadata.R | 85 +++++++++++++++++++++++----------- tests/testthat/test-pipe.R | 31 +++++++++---- 9 files changed, 211 insertions(+), 216 deletions(-) diff --git a/R/df_label.R b/R/df_label.R index 6ae77d51..18899604 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -27,46 +27,34 @@ #' #' adsl <- xportr_df_label(adsl, metacore) xportr_df_label <- function(.df, metacore, domain = NULL) { - + domain_name <- getOption("xportr.df_domain_name") label_name <- getOption("xportr.df_label") - - - df_arg <- as_name(enexpr(.df)) - - if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_") - else if (identical(df_arg, ".")) { - attr(.df, "_xportr.df_arg_") <- get_pipe_call() - df_arg <- attr(.df, "_xportr.df_arg_") - } - - if (!is.null(domain) && !is.character(domain)) { - abort(c("`domain` must be a vector with type .", - x = glue("Instead, it has type <{typeof(domain)}>.")) - ) - } - - df_arg <- domain %||% df_arg - + + ## Common section to detect domain from argument or pipes + + df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL) + domain <- get_domain(.df, df_arg, domain) if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - + + ## End of common section + if (inherits(metacore, "Metacore")) metacore <- metacore$ds_spec - + label <- metacore %>% - filter(!!sym(domain_name) == df_arg) %>% + filter(!!sym(domain_name) == domain) %>% select(!!sym(label_name)) %>% # If a dataframe is used this will also be a dataframe, change to character. as.character() - + label_len <- nchar(label) - + if (label_len > 40) { abort("Length of dataset label must be 40 characters or less.") } - - + attr(.df, "label") <- label - + .df } diff --git a/R/format.R b/R/format.R index b091916a..c874fe7e 100644 --- a/R/format.R +++ b/R/format.R @@ -28,57 +28,46 @@ #' #' adsl <- xportr_format(adsl, metacore) xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.format_verbose", "none")) { - + domain_name <- getOption("xportr.domain_name") format_name <- getOption("xportr.format_name") variable_name <- getOption("xportr.variable_name") - - - df_arg <- as_name(enexpr(.df)) - - if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_") - else if (identical(df_arg, ".")) { - attr(.df, "_xportr.df_arg_") <- get_pipe_call() - df_arg <- attr(.df, "_xportr.df_arg_") - } - - if (!is.null(domain) && !is.character(domain)) { - abort(c("`domain` must be a vector with type .", - x = glue("Instead, it has type <{typeof(domain)}>.")) - ) - } - - df_arg <- domain %||% df_arg - + + ## Common section to detect domain from argument or pipes + + df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL) + domain <- get_domain(.df, df_arg, domain) if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - + + ## End of common section + if (inherits(metacore, "Metacore")) metacore <- metacore$var_spec - + if (domain_name %in% names(metacore)) { metadata <- metacore %>% - dplyr::filter(!!sym(domain_name) == df_arg & !is.na(!!sym(format_name))) + dplyr::filter(!!sym(domain_name) == domain & !is.na(!!sym(format_name))) } else { metadata <- metacore } - + filtered_metadata <- metadata %>% filter(!!sym(variable_name) %in% names(.df)) - + format <- filtered_metadata %>% select(!!sym(format_name)) %>% unlist() %>% toupper() names(format) <- filtered_metadata[[variable_name]] - + 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 <- "" attr(.df[[i]], "format.sas") <- format_sas } - + .df } diff --git a/R/label.R b/R/label.R index 01c07ecb..f125569e 100644 --- a/R/label.R +++ b/R/label.R @@ -31,63 +31,53 @@ #' adsl <- xportr_label(adsl, metacore) xportr_label <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.label_verbose", "none")) { - + domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") variable_label <- getOption("xportr.label") - - df_arg <- as_name(enexpr(.df)) - - if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_") - else if (identical(df_arg, ".")) { - attr(.df, "_xportr.df_arg_") <- get_pipe_call() - df_arg <- attr(.df, "_xportr.df_arg_") - } - - if (!is.null(domain) && !is.character(domain)) { - abort(c("`domain` must be a vector with type .", - x = glue("Instead, it has type <{typeof(domain)}>.")) - ) - } - - df_arg <- domain %||% df_arg - + + ## Common section to detect domain from argument or pipes + + df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL) + domain <- get_domain(.df, df_arg, domain) if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - + + ## End of common section + if (inherits(metacore, "Metacore")) metacore <- metacore$var_spec - + if (domain_name %in% names(metacore)) { metadata <- metacore %>% - dplyr::filter(!!sym(domain_name) == df_arg) + dplyr::filter(!!sym(domain_name) == domain) } else { metadata <- metacore } - + # Check any variables missed in metadata but present in input data --- miss_vars <- setdiff(names(.df), metadata[[variable_name]]) label_log(miss_vars, verbose) - + label <- metadata[[variable_label]] names(label) <- metadata[[variable_name]] - + # Check any variable label have more than 40 characters --- label_len <- lapply(label, nchar) err_len <- which(label_len > 40) %>% names - + if (length(err_len) > 0) { warn( c("Length of variable label must be 40 characters or less.", x = glue("Problem with {encode_vars(err_len)}.")) ) } - + for (i in names(.df)) { if (i %in% miss_vars) attr(.df[[i]], "label") <- "" else attr(.df[[i]], "label") <- label[[i]] } - + .df } diff --git a/R/length.R b/R/length.R index 4167a27d..c6b48c28 100644 --- a/R/length.R +++ b/R/length.R @@ -34,30 +34,20 @@ xportr_length <- function(.df, metacore, domain = NULL, variable_length <- getOption("xportr.length") variable_name <- getOption("xportr.variable_name") - df_arg <- as_name(enexpr(.df)) - - if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_") - else if (identical(df_arg, ".")) { - attr(.df, "_xportr.df_arg_") <- get_pipe_call() - df_arg <- attr(.df, "_xportr.df_arg_") - } - - if (!is.null(domain) && !is.character(domain)) { - abort(c("`domain` must be a vector with type .", - x = glue("Instead, it has type <{typeof(domain)}>.")) - ) - } - - df_arg <- domain %||% df_arg + ## Common section to detect domain from argument or pipes + df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL) + domain <- get_domain(.df, df_arg, domain) if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + ## End of common section + if (inherits(metacore, "Metacore")) metacore <- metacore$var_spec if (domain_name %in% names(metacore)) { metadata <- metacore %>% - filter(!!sym(domain_name) == df_arg) + dplyr::filter(!!sym(domain_name) == domain) } else { metadata <- metacore } diff --git a/R/order.R b/R/order.R index 0b451258..94e9cbed 100644 --- a/R/order.R +++ b/R/order.R @@ -10,63 +10,52 @@ #' @return Dataframe that has been re-ordered according to spec #' xportr_order <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.order_verbose", "none")) { - + domain_name <- getOption("xportr.domain_name") order_name <- getOption("xportr.order_name") variable_name <- getOption("xportr.variable_name") - - - df_arg <- as_name(enexpr(.df)) - - if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_") - else if (identical(df_arg, ".")) { - attr(.df, "_xportr.df_arg_") <- get_pipe_call() - df_arg <- attr(.df, "_xportr.df_arg_") - } - - if (!is.null(domain) && !is.character(domain)) { - abort(c("`domain` must be a vector with type .", - x = glue("Instead, it has type <{typeof(domain)}>.")) - ) - } - - df_arg <- domain %||% df_arg - + + ## Common section to detect domain from argument or pipes + + df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL) + domain <- get_domain(.df, df_arg, domain) if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - + + ## End of common section + if (inherits(metacore, "Metacore")) metacore <- metacore$ds_vars - + if (domain_name %in% names(metacore)) { metadata <- metacore %>% - dplyr::filter(!!sym(domain_name) == df_arg & !is.na(!!sym(order_name))) + dplyr::filter(!!sym(domain_name) == domain & !is.na(!!sym(order_name))) } else { metadata <- metacore %>% dplyr::filter(!is.na(!!sym(order_name))) } - + # Grabs vars from Spec and inputted dataset vars_in_spec_ds <- metadata[, c(variable_name, order_name)] %>% arrange(!!sym(order_name)) %>% extract2(variable_name) - + vars_in_spec_ds <- vars_in_spec_ds[!is.na(vars_in_spec_ds)] # Grabs all variables from Spec file and orders accordingly ord_vars <- .df %>% select(any_of(vars_in_spec_ds)) - + # Variables not in Spec file - will be moved to the end drop_vars <- .df %>% select(!any_of(vars_in_spec_ds)) - + # Used in warning message for how many vars have been moved moved_vars <- ncol(drop_vars) ordered_vars <- ncol(ord_vars) - + df_re_ord <- bind_cols(ord_vars, drop_vars) - + # Function is located in messages.R var_ord_msg(moved_vars, verbose) - - return(df_re_ord) + + df_re_ord } diff --git a/R/type.R b/R/type.R index d8017b50..2e465b1f 100644 --- a/R/type.R +++ b/R/type.R @@ -33,41 +33,31 @@ #' df2 <- xportr_type(.df, metacore, "test") xportr_type <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.type_verbose", "none")) { - + # Name of the columns for working with metadata domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") type_name <- getOption("xportr.type_name") characterTypes <- getOption("xportr.character_types") - - if (!is.null(domain) && !is.character(domain)) { - abort(c("`domain` must be a vector with type .", - x = glue("Instead, it has type <{typeof(domain)}>.")) - ) - } - - df_arg <- as_name(enexpr(.df)) - - if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_") - else if (identical(df_arg, ".")) { - attr(.df, "_xportr.df_arg_") <- get_pipe_call() - df_arg <- attr(.df, "_xportr.df_arg_") - } - - domain <- domain %||% df_arg - + + ## Common section to detect domain from argument or pipes + + df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL) + domain <- get_domain(.df, df_arg, domain) if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - + + ## End of common section + ## Pull out correct metadata if ("Metacore" %in% class(metacore)) metacore <- metacore$var_spec - + if (domain_name %in% names(metacore)) { metacore <- metacore %>% filter(!!sym(domain_name) == domain) } metacore <- metacore %>% select(!!sym(variable_name), !!sym(type_name)) - + # Current class of table variables table_cols_types <- map(.df, first_class) @@ -77,15 +67,15 @@ xportr_type <- function(.df, metacore, domain = NULL, metacore, by = "variable" ) - + # It is possible that a variable exists in the table that isn't in the metadata # it will be silently ignored here. This may happen depending on what a user # passes and the options they choose. The check_core function is the place # where this should be caught. type_mismatch_ind <- which(meta_ordered$type.x != meta_ordered$type.y) type_log(meta_ordered, type_mismatch_ind, verbose) - - + + # Check if variable types match is_correct <- sapply(meta_ordered[["type.x"]] == meta_ordered[["type.y"]], isTRUE) # Use the original variable iff metadata is missing that variable @@ -104,6 +94,6 @@ xportr_type <- function(.df, metacore, domain = NULL, attributes(.df[[i]]) <<- orig_attributes } }, is_correct) - + .df } diff --git a/R/utils-xportr.R b/R/utils-xportr.R index 5df65503..233a61e4 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -49,7 +49,7 @@ encode_vars <- function(x) { if (is.character(x)) { x <- encodeString(x, quote = "`") } - + fmt_comma(x) } @@ -64,7 +64,7 @@ encode_vals <- function(x) { if (is.character(x)) { x <- encodeString(x, quote = "'") } - + fmt_comma(x) } @@ -119,43 +119,43 @@ fmt_fmts <- function(x) { xpt_validate_var_names <- function(varnames, list_vars_first = TRUE, err_cnd = character()) { - + # 1.1 Check length -- chk_varlen <- varnames[nchar(varnames) > 8] - + if (length(chk_varlen) > 0) { err_cnd <- c(err_cnd, ifelse(list_vars_first, glue("{fmt_vars(chk_varlen)} must be 8 characters or less."), glue(" Must be 8 characters or less: {fmt_vars(chk_varlen)}."))) } - + # 1.2 Check first character -- chk_first_chr <- varnames[stringr::str_detect(stringr::str_sub(varnames, 1, 1), "[^[:alpha:]]")] - + if (length(chk_first_chr) > 0) { err_cnd <- c(err_cnd, ifelse(list_vars_first, glue("{fmt_vars(chk_first_chr)} must start with a letter."), glue(" Must start with a letter: {fmt_vars(chk_first_chr)}."))) } - + # 1.3 Check Non-ASCII and underscore characters -- chk_alnum <- varnames[stringr::str_detect(varnames, "[^a-zA-Z0-9]")] - + if (length(chk_alnum) > 0) { err_cnd <- c(err_cnd, ifelse(list_vars_first, glue("{fmt_vars(chk_alnum)} cannot contain any non-ASCII, symbol or underscore characters."), glue(" Cannot contain any non-ASCII, symbol or underscore characters: {fmt_vars(chk_alnum)}."))) } - + # 1.4 Check for any lowercase letters - or not all uppercase chk_lower <- varnames[!stringr::str_detect( stringr::str_replace_all(varnames, "[:digit:]", ""), "^[[:upper:]]+$")] - + if (length(chk_lower) > 0) { err_cnd <- c(err_cnd, ifelse(list_vars_first, glue("{fmt_vars(chk_lower)} cannot contain any lowercase characters."), @@ -172,50 +172,50 @@ xpt_validate_var_names <- function(varnames, #' @return xpt file #' @noRd xpt_validate <- function(data) { - + err_cnd <- character() - + # 1.0 VARIABLES ---- varnames <- names(data) err_cnd <- xpt_validate_var_names(varnames = varnames, err_cnd = err_cnd) - - + + # 2.0 LABELS ---- labels <- extract_attr(data, attr = "label") - + # 2.1 Check length -- chk_label_len <- labels[nchar(labels) > 40] - + if (length(chk_label_len) > 0) { err_cnd <- c(err_cnd, glue("{fmt_labs(chk_label_len)} must be 40 characters or less.")) } - + # 2.2 Check Non-ASCII and special characters chk_spl_chr <- labels[stringr::str_detect(labels, "[<>]|[^[:ascii:]]")] - + if (length(chk_spl_chr) > 0) { err_cnd <- c(err_cnd, glue("{fmt_labs(chk_spl_chr)} cannot contain any non-ASCII, symbol or special characters.")) } - + # 3.0 VARIABLE TYPES ---- types <- tolower(extract_attr(data, attr = "SAStype")) expected_types <- c("", "text", "integer", "float", "datetime", "date", "time", "partialdate", "partialtime", "partialdatetime", "incompletedatetime", "durationdatetime", "intervaldatetime") - + # 3.1 Invalid types -- chk_types <- types[which(!types %in% expected_types)] - + if (length(chk_types) > 0) { err_cnd <- c(err_cnd, glue("{fmt_vars(names(types))} must have a valid type.")) } - + # 4.0 Format Types ---- formats <- tolower(extract_attr(data, attr = "format.sas")) - + ## The usual expected formats in clinical trials: characters, dates expected_formats <- c(NA, "", @@ -226,9 +226,9 @@ xpt_validate <- function(data) { paste("yymmdd", 2:10, ".", sep = ""), paste("mmddyy", 2:10, ".", sep = ""), paste("ddmmyy", 2:10, ".", sep = "")) - + chk_formats <- formats[which(!formats %in% expected_formats)] - + ## Remove the correctly numerically formatted variables format_regex <- "^([1-9]|[12][0-9]|3[0-2])\\.$|^([1-9]|[12][0-9]|3[0-2])\\.([1-9]|[12][0-9]|3[0-1])$" chk_formats <- chk_formats[which(!str_detect(chk_formats, format_regex))] @@ -239,14 +239,33 @@ xpt_validate <- function(data) { return(err_cnd) } +#' Get the domain from argument or from magrittr's pipe (`%>%`) +#' +#' @return A string representing the domain +#' @noRd +get_domain <- function(.df, df_arg, domain) { + if (!is.null(domain) && !is.character(domain)) { + abort(c("`domain` must be a vector with type .", + x = glue("Instead, it has type <{typeof(domain)}>.")) + ) + } + + if (identical(df_arg, ".")) { + df_arg <- get_pipe_call() + } + + result <- domain %||% attr(.df, "_xportr.df_arg_") %||% df_arg + result +} + #' Get Origin Object of a Series of Pipes #' #' @return The R Object at the top of a pipe stack #' @noRd get_pipe_call <- function() { - call_strs <- map_chr(sys.calls(), as_label) + call_strs <- map_chr(sys.calls(), deparse1) top_call <- min(which(str_detect(call_strs, "%>%"))) - call_str <- as_label(sys.calls()[[top_call]]) + call_str <- call_strs[[top_call]] trimws(strsplit(call_str, "%>%", fixed = TRUE)[[1]][[1]]) } diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index 2e75053a..2789d211 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -12,30 +12,42 @@ test_that("Variable label", { varmeta <- data.frame(dataset = rep("df", 2), variable = c("x", "y"), label = c("foo", "bar")) - + extract_varlabel <- function(.x) { vapply(.x, function(.x) attr(.x, "label"), character(1), USE.NAMES = FALSE) } - + df <- xportr_label(df, varmeta) df_dput <- dput(df) - + expect_equal(extract_varlabel(df), c("foo", "bar")) - expect_equal(df_dput, - structure(list(x = structure("a", label = "foo"), - y = structure("b", label = "bar")), - row.names = c(NA, -1L), class = "data.frame")) + expect_equal( + df_dput, + structure( + list( + x = structure("a", label = "foo"), + y = structure("b", label = "bar") + ), + row.names = c(NA, -1L), + class = "data.frame", + `_xportr.df_arg_` = "df" + )) }) test_that("Dataset label", { df <- data.frame(x = "a", y = "b") dfmeta <- data.frame(dataset = "df", label = "Label") - + df <- xportr_df_label(df, dfmeta) expect_equal(attr(df, "label"), "Label") - expect_equal(dput(df), structure(list(x = "a", y = "b"), class = "data.frame", - row.names = c(NA, -1L), label = "Label")) + expect_equal(dput(df), structure( + list(x = "a", y = "b"), + class = "data.frame", + row.names = c(NA, -1L), + label = "Label", + `_xportr.df_arg_` = "df" + )) }) test_that("Expect error if any variable doesn't exist in var. metadata", { @@ -43,7 +55,7 @@ test_that("Expect error if any variable doesn't exist in var. metadata", { varmeta <- data.frame(dataset = "df", variable = "x", label = "foo") - + # expect_error(xportr_label(df, varmeta, verbose = "stop"), # "present in `.df` but doesn't exist in `datadef`") }) @@ -55,7 +67,7 @@ test_that("Expect error if any label exceeds 40 character", { label = c("foo", "Lorem ipsum dolor sit amet, consectetur adipiscing elit")) dfmeta <- data.frame(dataset = "df", label = "Lorem ipsum dolor sit amet, consectetur adipiscing elit") - + expect_warning(xportr_label(df, varmeta), "variable label must be 40 characters or less") expect_error(xportr_df_label(df, dfmeta), @@ -67,15 +79,21 @@ test_that("xportr_format will set formats as expected", { varmeta <- data.frame(dataset = rep("df", 2), variable = c("x", "y"), format = c("date9.", "datetime20.")) - - + + out <- xportr_format(df, varmeta) - + expect_equal(extract_format(out), c("DATE9.", "DATETIME20.")) - expect_equal(dput(out), structure(list(x = structure(1, format.sas = "DATE9."), - y = structure(2, format.sas = "DATETIME20.")), - row.names = c(NA, -1L), class = "data.frame")) + expect_equal(dput(out), structure( + list( + x = structure(1, format.sas = "DATE9."), + y = structure(2, format.sas = "DATETIME20.") + ), + row.names = c(NA, -1L), + class = "data.frame", + `_xportr.df_arg_` = "df" + )) }) test_that("xportr_format will handle NA values and won't error", { @@ -83,15 +101,21 @@ test_that("xportr_format will handle NA values and won't error", { varmeta <- data.frame(dataset = rep("df", 4), variable = c("x", "y", "z", "abc"), format = c("date9.", "datetime20.", NA, "text")) - + out <- xportr_format(df, varmeta) - + expect_equal(extract_format(out), c("DATE9.", "DATETIME20.", "", "")) - expect_equal(dput(out), structure(list(x = structure(1, format.sas = "DATE9."), - y = structure(2, format.sas = "DATETIME20."), - z = structure(3, format.sas = ""), - a = structure(4, format.sas = "")), - row.names = c(NA, -1L), class = "data.frame")) + expect_equal(dput(out), structure( + list( + x = structure(1, format.sas = "DATE9."), + y = structure(2, format.sas = "DATETIME20."), + z = structure(3, format.sas = ""), + a = structure(4, format.sas = "") + ), + row.names = c(NA, -1L), + class = "data.frame", + `_xportr.df_arg_` = "df" + )) }) test_that("Error ", { @@ -119,9 +143,14 @@ test_that("SAS length", { out <- xportr_length(df, varmeta) expect_equal(c(x = 1, y = 1), map_dbl(out, attr, "width")) - expect_equal(dput(out), structure(list(x = structure("a", width = 1), - y = structure("b", width = 1)), - row.names = c(NA, -1L), class = "data.frame")) + expect_equal(dput(out), structure( + list( + x = structure("a", width = 1), + y = structure("b", width = 1)), + row.names = c(NA, -1L), + class = "data.frame", + `_xportr.df_arg_` = "df" + )) df <- cbind(df, z = 3) expect_error(xportr_length(df, varmeta, verbose = "stop"), "doesn't exist") diff --git a/tests/testthat/test-pipe.R b/tests/testthat/test-pipe.R index ee214ce3..27f82821 100644 --- a/tests/testthat/test-pipe.R +++ b/tests/testthat/test-pipe.R @@ -1,4 +1,6 @@ test_that("xportr_*: Can use magrittr to pipe", { + withr::local_options(list(xportr.type_verbose = "message")) + adsl <- dplyr::tibble( USUBJID = c(1001, 1002, 1003), SITEID = c(001, 002, 003), @@ -13,25 +15,31 @@ test_that("xportr_*: Can use magrittr to pipe", { label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"), type = c("character", "character", "character", "numeric", "character"), length = c(10, 10, 10, 8, 10), - format = c(NA, NA, "DATE9.", NA, NA) + format = c(NA, NA, "DATE9.", NA, NA), + order = c(1, 2, 3, 4, 5) ) - result <- adsl %>% + non_standard_name <- adsl + result <- non_standard_name %>% xportr_type(metadata) %>% xportr_label(metadata) %>% xportr_length(metadata) %>% - xportr_format(metadata) + xportr_order(metadata) %>% + xportr_format(metadata) %>% + xportr_df_label(metadata) - attr(result, "_xportr.df_arg_") %>% - expect_equal("adsl") + expect_equal(attr(result, "_xportr.df_arg_"), "non_standard_name") }) test_that("xportr_*: Can use R native pipe (R>4.1)", { + #skip("yada") skip_if( compareVersion(glue("{R.version$major}.{R.version$minor}"), "4.1.0") < 0, "R Version doesn't support native pipe (<4.1)" ) + withr::local_options(list(xportr.type_verbose = "message")) + adsl <- dplyr::tibble( USUBJID = c(1001, 1002, 1003), SITEID = c(001, 002, 003), @@ -46,15 +54,18 @@ test_that("xportr_*: Can use R native pipe (R>4.1)", { label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"), type = c("character", "character", "character", "numeric", "character"), length = c(10, 10, 10, 8, 10), - format = c(NA, NA, "DATE9.", NA, NA) + format = c(NA, NA, "DATE9.", NA, NA), + order = c(1, 2, 3, 4, 5) ) - result <- adsl |> + non_standard_name_native <- adsl + result <- non_standard_name_native |> xportr_type(metadata) |> xportr_label(metadata) |> xportr_length(metadata) |> - xportr_format(metadata) + xportr_order(metadata) |> + xportr_format(metadata) |> + xportr_df_label(metadata) - attr(result, "_xportr.df_arg_") %>% - expect_equal("adsl") + expect_equal(attr(result, "_xportr.df_arg_"), "non_standard_name_native") }) From 0d2c02e82dffdd40674d08ba1b8ada197fd2f684 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 15:33:50 +0200 Subject: [PATCH 06/26] revert to max --- R/utils-xportr.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils-xportr.R b/R/utils-xportr.R index 233a61e4..c7676043 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -264,7 +264,7 @@ get_domain <- function(.df, df_arg, domain) { #' @noRd get_pipe_call <- function() { call_strs <- map_chr(sys.calls(), deparse1) - top_call <- min(which(str_detect(call_strs, "%>%"))) + top_call <- max(which(str_detect(call_strs, "%>%"))) call_str <- call_strs[[top_call]] trimws(strsplit(call_str, "%>%", fixed = TRUE)[[1]][[1]]) } From f162c1f7194b475b94b1e32add688e88623a9af5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 15:36:02 +0200 Subject: [PATCH 07/26] remove dplyr:: namespace according to guidelines --- R/length.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/length.R b/R/length.R index c6b48c28..5a9966d7 100644 --- a/R/length.R +++ b/R/length.R @@ -47,7 +47,7 @@ xportr_length <- function(.df, metacore, domain = NULL, if (domain_name %in% names(metacore)) { metadata <- metacore %>% - dplyr::filter(!!sym(domain_name) == domain) + filter(!!sym(domain_name) == domain) } else { metadata <- metacore } From 6a079b4632e8468c4476719bfb7eef676bb456a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 15:42:25 +0200 Subject: [PATCH 08/26] break test into 2 expressions --- tests/testthat/test-length.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-length.R b/tests/testthat/test-length.R index 4c98b696..52561888 100644 --- a/tests/testthat/test-length.R +++ b/tests/testthat/test-length.R @@ -113,10 +113,11 @@ test_that("xportr_length: Impute character lengths based on class", { withr::defer(cli::stop_app(app)) # Test length imputation of character and numeric (not valid character type) - adsl %>% + result <- adsl %>% xportr_length(metadata) %>% - expect_silent() %>% - expect_attr_width(c(7, 199)) + expect_silent() + + expect_attr_width(result, c(7, 199)) # Test length imputation of two valid character types (both should have # `width = 200``) From 80eaeb387b005db9e12710f4caf537d6af4239ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 16:28:29 +0200 Subject: [PATCH 09/26] add test to see if domain is kept between calls --- R/utils-xportr.R | 1 - tests/testthat/test-pipe.R | 67 +++++++++++++++++++++++++++++++++++++- 2 files changed, 66 insertions(+), 2 deletions(-) diff --git a/R/utils-xportr.R b/R/utils-xportr.R index c7676043..dcce7bc7 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -253,7 +253,6 @@ get_domain <- function(.df, df_arg, domain) { if (identical(df_arg, ".")) { df_arg <- get_pipe_call() } - result <- domain %||% attr(.df, "_xportr.df_arg_") %||% df_arg result } diff --git a/tests/testthat/test-pipe.R b/tests/testthat/test-pipe.R index 27f82821..cad91975 100644 --- a/tests/testthat/test-pipe.R +++ b/tests/testthat/test-pipe.R @@ -1,3 +1,47 @@ +test_that("xportr_*: Domain is kept in between calls", { + withr::local_options(list(xportr.type_verbose = "message")) + + adsl <- dplyr::tibble( + USUBJID = c(1001, 1002, 1003), + SITEID = c(001, 002, 003), + ADATE = readr::parse_date(c("2023-04-11", "2023-04-12", "2023-04-13")), + AGE = c(63, 35, 27), + SEX = c("M", "F", "M") + ) + + metadata <- dplyr::tibble( + dataset = "adsl", + variable = c("USUBJID", "SITEID", "ADATE", "AGE", "SEX"), + label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"), + type = c("character", "character", "character", "numeric", "character"), + length = c(10, 10, 10, 8, 10), + format = c(NA, NA, "DATE9.", NA, NA), + order = c(1, 2, 3, 4, 5) + ) + + df2 <- adsl %>% + xportr_type(metadata) + + df3 <- df2 %>% + xportr_label(metadata) %>% + xportr_length(metadata) %>% + xportr_order(metadata) %>% + xportr_format(metadata) + + expect_equal(attr(df3, "_xportr.df_arg_"), "adsl") + + df4 <- adsl %>% + xportr_type(metadata) + + df5 <- df4 %>% + xportr_label(metadata) %>% + xportr_length(metadata) %>% + xportr_order(metadata) %>% + xportr_format(metadata) + + expect_equal(attr(df5, "_xportr.df_arg_"), "adsl") +}) + test_that("xportr_*: Can use magrittr to pipe", { withr::local_options(list(xportr.type_verbose = "message")) @@ -29,10 +73,20 @@ test_that("xportr_*: Can use magrittr to pipe", { xportr_df_label(metadata) expect_equal(attr(result, "_xportr.df_arg_"), "non_standard_name") + + # xportr_type in a different order + result2 <- non_standard_name %>% + xportr_label(metadata) %>% + xportr_length(metadata) %>% + xportr_order(metadata) %>% + xportr_df_label(metadata) %>% + xportr_type(metadata) %>% + xportr_format(metadata) + + expect_equal(attr(result2, "_xportr.df_arg_"), "non_standard_name") }) test_that("xportr_*: Can use R native pipe (R>4.1)", { - #skip("yada") skip_if( compareVersion(glue("{R.version$major}.{R.version$minor}"), "4.1.0") < 0, "R Version doesn't support native pipe (<4.1)" @@ -68,4 +122,15 @@ test_that("xportr_*: Can use R native pipe (R>4.1)", { xportr_df_label(metadata) expect_equal(attr(result, "_xportr.df_arg_"), "non_standard_name_native") + + # xportr_type in a different order + result2 <- non_standard_name |> + xportr_label(metadata) |> + xportr_length(metadata) |> + xportr_order(metadata) |> + xportr_df_label(metadata) |> + xportr_type(metadata) |> + xportr_format(metadata) + + expect_equal(attr(result2, "_xportr.df_arg_"), "non_standard_name") }) From 2102de2664b8a61ede8817cbfad747bd61811b20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 16:34:50 +0200 Subject: [PATCH 10/26] use minimal data functions and expand on domain-based tests --- tests/testthat/test-pipe.R | 77 +++++++++++++++----------------------- 1 file changed, 30 insertions(+), 47 deletions(-) diff --git a/tests/testthat/test-pipe.R b/tests/testthat/test-pipe.R index cad91975..0ea5e189 100644 --- a/tests/testthat/test-pipe.R +++ b/tests/testthat/test-pipe.R @@ -1,22 +1,27 @@ +test_that("xportr_*: Domain is obtained from a call without pipe", { + adsl <- minimal_table(30) + + metadata <- minimal_metadata( + dataset = TRUE, length = TRUE, label = TRUE, type = TRUE, format = TRUE, + order = TRUE + ) + + xportr_label(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") + xportr_length(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") + xportr_order(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") + xportr_format(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") + xportr_type(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") +}) + + test_that("xportr_*: Domain is kept in between calls", { withr::local_options(list(xportr.type_verbose = "message")) - adsl <- dplyr::tibble( - USUBJID = c(1001, 1002, 1003), - SITEID = c(001, 002, 003), - ADATE = readr::parse_date(c("2023-04-11", "2023-04-12", "2023-04-13")), - AGE = c(63, 35, 27), - SEX = c("M", "F", "M") - ) + adsl <- minimal_table(30) - metadata <- dplyr::tibble( - dataset = "adsl", - variable = c("USUBJID", "SITEID", "ADATE", "AGE", "SEX"), - label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"), - type = c("character", "character", "character", "numeric", "character"), - length = c(10, 10, 10, 8, 10), - format = c(NA, NA, "DATE9.", NA, NA), - order = c(1, 2, 3, 4, 5) + metadata <- minimal_metadata( + dataset = TRUE, length = TRUE, label = TRUE, type = TRUE, format = TRUE, + order = TRUE ) df2 <- adsl %>% @@ -42,25 +47,14 @@ test_that("xportr_*: Domain is kept in between calls", { expect_equal(attr(df5, "_xportr.df_arg_"), "adsl") }) -test_that("xportr_*: Can use magrittr to pipe", { +test_that("xportr_*: Can use magrittr to pipe and aquire domain from call", { withr::local_options(list(xportr.type_verbose = "message")) - adsl <- dplyr::tibble( - USUBJID = c(1001, 1002, 1003), - SITEID = c(001, 002, 003), - ADATE = readr::parse_date(c("2023-04-11", "2023-04-12", "2023-04-13")), - AGE = c(63, 35, 27), - SEX = c("M", "F", "M") - ) + adsl <- minimal_table(30) - metadata <- dplyr::tibble( - dataset = "adsl", - variable = c("USUBJID", "SITEID", "ADATE", "AGE", "SEX"), - label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"), - type = c("character", "character", "character", "numeric", "character"), - length = c(10, 10, 10, 8, 10), - format = c(NA, NA, "DATE9.", NA, NA), - order = c(1, 2, 3, 4, 5) + metadata <- minimal_metadata( + dataset = TRUE, length = TRUE, label = TRUE, type = TRUE, format = TRUE, + order = TRUE ) non_standard_name <- adsl @@ -86,7 +80,7 @@ test_that("xportr_*: Can use magrittr to pipe", { expect_equal(attr(result2, "_xportr.df_arg_"), "non_standard_name") }) -test_that("xportr_*: Can use R native pipe (R>4.1)", { +test_that("xportr_*: Can use R native pipe (R>4.1) and aquire domain from call", { skip_if( compareVersion(glue("{R.version$major}.{R.version$minor}"), "4.1.0") < 0, "R Version doesn't support native pipe (<4.1)" @@ -94,22 +88,11 @@ test_that("xportr_*: Can use R native pipe (R>4.1)", { withr::local_options(list(xportr.type_verbose = "message")) - adsl <- dplyr::tibble( - USUBJID = c(1001, 1002, 1003), - SITEID = c(001, 002, 003), - ADATE = readr::parse_date(c("2023-04-11", "2023-04-12", "2023-04-13")), - AGE = c(63, 35, 27), - SEX = c("M", "F", "M") - ) + adsl <- minimal_table(30) - metadata <- dplyr::tibble( - dataset = "adsl", - variable = c("USUBJID", "SITEID", "ADATE", "AGE", "SEX"), - label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"), - type = c("character", "character", "character", "numeric", "character"), - length = c(10, 10, 10, 8, 10), - format = c(NA, NA, "DATE9.", NA, NA), - order = c(1, 2, 3, 4, 5) + metadata <- minimal_metadata( + dataset = TRUE, length = TRUE, label = TRUE, type = TRUE, format = TRUE, + order = TRUE ) non_standard_name_native <- adsl From 8a4b531107f71ee638e8f0d8753083294f0ac4ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 16:43:38 +0200 Subject: [PATCH 11/26] avoid using pairlist --- R/utils-xportr.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils-xportr.R b/R/utils-xportr.R index dcce7bc7..b22b69b0 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -262,7 +262,7 @@ get_domain <- function(.df, df_arg, domain) { #' @return The R Object at the top of a pipe stack #' @noRd get_pipe_call <- function() { - call_strs <- map_chr(sys.calls(), deparse1) + call_strs <- map(sys.calls(), deparse1) top_call <- max(which(str_detect(call_strs, "%>%"))) call_str <- call_strs[[top_call]] trimws(strsplit(call_str, "%>%", fixed = TRUE)[[1]][[1]]) From 50782019b80ea21a6ffe8117ddd164fa3156ac83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 16:49:27 +0200 Subject: [PATCH 12/26] fix was not working, should be corrected in CI --- R/utils-xportr.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils-xportr.R b/R/utils-xportr.R index b22b69b0..98969649 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -262,7 +262,7 @@ get_domain <- function(.df, df_arg, domain) { #' @return The R Object at the top of a pipe stack #' @noRd get_pipe_call <- function() { - call_strs <- map(sys.calls(), deparse1) + call_strs <- map(as.list(sys.calls()), ~deparse1(.x, nlines = 1)) top_call <- max(which(str_detect(call_strs, "%>%"))) call_str <- call_strs[[top_call]] trimws(strsplit(call_str, "%>%", fixed = TRUE)[[1]][[1]]) From c9a97ae87a5a603e201097c1f1a46b3f06ec8cd4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 28 Apr 2023 16:58:40 +0200 Subject: [PATCH 13/26] corrects variable name and removes duplicate entry of all_of --- R/xportr-package.R | 2 +- tests/testthat/test-pipe.R | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/xportr-package.R b/R/xportr-package.R index b075d78c..ef677962 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -7,7 +7,7 @@ #' @import rlang haven #' @importFrom dplyr left_join bind_cols filter select rename rename_with n #' everything arrange group_by summarize mutate ungroup case_when distinct -#' tribble all_of +#' tribble #' @importFrom glue glue glue_collapse #' @importFrom cli cli_alert_info cli_h2 cli_alert_success cli_alert_info #' cli_div cli_alert_success cli_text cli_h2 diff --git a/tests/testthat/test-pipe.R b/tests/testthat/test-pipe.R index 0ea5e189..4adb4bf0 100644 --- a/tests/testthat/test-pipe.R +++ b/tests/testthat/test-pipe.R @@ -68,7 +68,7 @@ test_that("xportr_*: Can use magrittr to pipe and aquire domain from call", { expect_equal(attr(result, "_xportr.df_arg_"), "non_standard_name") - # xportr_type in a different order + # Different sequence call by moving first and last around result2 <- non_standard_name %>% xportr_label(metadata) %>% xportr_length(metadata) %>% @@ -106,8 +106,8 @@ test_that("xportr_*: Can use R native pipe (R>4.1) and aquire domain from call", expect_equal(attr(result, "_xportr.df_arg_"), "non_standard_name_native") - # xportr_type in a different order - result2 <- non_standard_name |> + # Different sequence call by moving first and last around + result2 <- non_standard_name_native |> xportr_label(metadata) |> xportr_length(metadata) |> xportr_order(metadata) |> @@ -115,5 +115,5 @@ test_that("xportr_*: Can use R native pipe (R>4.1) and aquire domain from call", xportr_type(metadata) |> xportr_format(metadata) - expect_equal(attr(result2, "_xportr.df_arg_"), "non_standard_name") + expect_equal(attr(result2, "_xportr.df_arg_"), "non_standard_name_native") }) From 45692feff828636896db14648fed5c6298175c14 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 1 May 2023 23:53:38 +0530 Subject: [PATCH 14/26] feat: adding tests to increase the coverage --- tests/testthat/test-metadata.R | 4 +- tests/testthat/test-pkg-load.R | 10 +++++ tests/testthat/test-type.R | 33 ++++++++++++++ tests/testthat/test-utils-xportr.R | 28 +++++++++++- tests/testthat/test-write.R | 69 +++++++++++++++++++----------- 5 files changed, 116 insertions(+), 28 deletions(-) create mode 100644 tests/testthat/test-pkg-load.R diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index 22fd0c47..850e4426 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -165,7 +165,9 @@ test_that("xportr_df_label: Correctly applies label when data is piped", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "df", label = "Label") - df_spec_labeled_df <- df %>% xportr_df_label(df_meta) + df_spec_labeled_df <- df %>% + xportr_df_label(df_meta) %>% + xportr_df_label(df_meta) expect_equal(attr(df_spec_labeled_df, "label"), "Label") expect_equal( diff --git a/tests/testthat/test-pkg-load.R b/tests/testthat/test-pkg-load.R new file mode 100644 index 00000000..2a1c0a19 --- /dev/null +++ b/tests/testthat/test-pkg-load.R @@ -0,0 +1,10 @@ +test_that(".onLoad: Unset options get initialised on package load with defaults", { + skip_if(getOption("testthat_interactive")) + withr::with_options( + list(xportr.df_domain_name = NULL), + { + expect_no_error(.onLoad()) + expect_equal(getOption("xportr.df_domain_name"), "dataset") + } + ) +}) diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R index 88f2d770..df2d3fa1 100644 --- a/tests/testthat/test-type.R +++ b/tests/testthat/test-type.R @@ -63,3 +63,36 @@ test_that("xportr_type() retains column attributes, besides class", { expect_equal(df_type_label, df_label_type) }) + + +test_that("xportr_type: expect error when domain is not a character", { + df <- data.frame(x = 1, y = 2) + df_meta <- data.frame( + variable = c("x", "y"), + type = "text", + label = c("X Label", "Y Label"), + length = c(1, 2), + common = NA_character_, + format = c("date9.", "datetime20.") + ) + expect_error(xportr_type(df, df_meta, domain = 1)) + expect_error(xportr_type(df, df_meta, domain = NA)) +}) + +test_that("xportr_type: works fine from metacore spec", { + df <- data.frame(x = 1, y = 2) + metacore_meta <- suppressWarnings( + metacore::metacore( + var_spec = data.frame( + variable = c("x", "y"), + type = "text", + label = c("X Label", "Y Label"), + length = c(1, 2), + common = NA_character_, + format = c("date9.", "datetime20.") + ) + ) + ) + processed_df <- xportr_type(df, metacore_meta) + expect_equal(processed_df$x, "1") +}) diff --git a/tests/testthat/test-utils-xportr.R b/tests/testthat/test-utils-xportr.R index 93de69db..64ae8237 100644 --- a/tests/testthat/test-utils-xportr.R +++ b/tests/testthat/test-utils-xportr.R @@ -2,11 +2,11 @@ test_that("Get magrittr lhs side value", { x <- function(df, var) { get_pipe_call() } - + y <- function(df) { get_pipe_call() } - + expect_equal({ mtcars %>% x("cyl") }, @@ -16,3 +16,27 @@ test_that("Get magrittr lhs side value", { }, "mtcars") }) + + +test_that("fmt_vars: the message returns properly formatted variables", { + expect_equal(fmt_vars(4), "Variable 4") + expect_equal(fmt_vars(4:6), "Variables 4, 5, and 6") +}) + +test_that("fmt_labs: the message returns properly formatted labels", { + expect_equal(fmt_labs(4), "Label '=4'") + expect_equal(fmt_labs(4:6), "Labels '=4', '=5', and '=6'") +}) + +test_that("xpt_validate_var_names: ", { + xpt_validate_var_names(c("A", "Bajskflas", "2klsd", "asdf_asdf")) + expect_equal(1, 1) +}) + +test_that("xpt_validate", { + df <- data.frame(A = 1, B = 2) + attr(df$A, "label") <- "asdfkajsdkj_fhaksjdfkajshdfkajsdfkjhk.xpt") on.exit(unlink(tmpdir)) - nameover8 <- data.frame(a = c(1, 2, NA), - b = c("a", "", "c"), - c = c(1, 2, 3)) + expect_error(xportr_write(data_to_save, tmp, label = "asdf")) +}) - expect_error(xportr_write(df, path = tmp)) +test_that("xportr_write: expect error when label contains non-ASCII symbols or special characters", { + tmpdir <- tempdir() + tmp <- file.path(tmpdir, "xyz.xpt") + on.exit(unlink(tmpdir)) + expect_error(xportr_write(data_to_save, tmp, label = "")) }) -test_that("Format message given if unexpected formats", { +test_that("xportr_write: expect error when label is over 40 characters", { tmpdir <- tempdir() tmp <- file.path(tmpdir, "xyz.xpt") on.exit(unlink(tmpdir)) - df <- data.frame(USUBJID = c("1001", "1002", "10003"), - AGE = c("M", "F", "M"), - BIRTHDT = as.Date(c("2001-01-01", "1997-11-11", "1995-12-12"), "%Y-%m-%d")) + expect_error(xportr_write(data_to_save, tmp, label = paste(rep("a", 41), collapse = ""))) +}) - # Forget the period in date9. - attr(df$BIRTHDT, "format.sas") <- "date9" +test_that("xportr_write: expect error when an xpt validation fails", { + tmpdir <- tempdir() + tmp <- file.path(tmpdir, "xyz.xpt") + attr(data_to_save$X, "format.sas") <- "foo" + + on.exit(unlink(tmpdir)) - expect_error(xportr_write(df, tmp)) + expect_error(xportr_write(data_to_save, tmp, label = "label")) }) From 77d521dde811c50f5c5367ac7feef455c6844330 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 May 2023 00:07:46 +0530 Subject: [PATCH 15/26] chore: lint the files using tidyverse styleguide --- tests/testthat/test-type.R | 34 ++++++++++++++++++------------ tests/testthat/test-utils-xportr.R | 22 ++++++++++++------- 2 files changed, 34 insertions(+), 22 deletions(-) diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R index df2d3fa1..acab855a 100644 --- a/tests/testthat/test-type.R +++ b/tests/testthat/test-type.R @@ -1,4 +1,3 @@ - meta_example <- data.frame( dataset = "df", variable = c("Subj", "Param", "Val", "NotUsed"), @@ -6,29 +5,36 @@ meta_example <- data.frame( ) df <- data.frame( - Subj = as.character(123, 456, 789), - Different = c("a", "b", "c"), - Val = c("1", "2", "3"), - Param = c("param1", "param2", "param3") + Subj = as.character(123, 456, 789), + Different = c("a", "b", "c"), + Val = c("1", "2", "3"), + Param = c("param1", "param2", "param3") ) test_that("variable types are coerced as expected and can raise messages", { + expect_message( + df2 <- xportr_type(df, meta_example), + "-- Variable type mismatches found. --" + ) - expect_message(df2 <- xportr_type(df, meta_example), - "-- Variable type mismatches found. --") - - expect_equal(purrr::map_chr(df2, class), c(Subj = "numeric", Different = "character", - Val = "numeric", Param = "character")) + expect_equal(purrr::map_chr(df2, class), c( + Subj = "numeric", Different = "character", + Val = "numeric", Param = "character" + )) expect_error(xportr_type(df, meta_example, verbose = "stop")) expect_warning(df3 <- xportr_type(df, meta_example, verbose = "warn")) - expect_equal(purrr::map_chr(df3, class), c(Subj = "numeric", Different = "character", - Val = "numeric", Param = "character")) + expect_equal(purrr::map_chr(df3, class), c( + Subj = "numeric", Different = "character", + Val = "numeric", Param = "character" + )) expect_message(df4 <- xportr_type(df, meta_example, verbose = "message")) - expect_equal(purrr::map_chr(df4, class), c(Subj = "numeric", Different = "character", - Val = "numeric", Param = "character")) + expect_equal(purrr::map_chr(df4, class), c( + Subj = "numeric", Different = "character", + Val = "numeric", Param = "character" + )) }) test_that("xportr_type() retains column attributes, besides class", { diff --git a/tests/testthat/test-utils-xportr.R b/tests/testthat/test-utils-xportr.R index 64ae8237..2e202156 100644 --- a/tests/testthat/test-utils-xportr.R +++ b/tests/testthat/test-utils-xportr.R @@ -7,14 +7,20 @@ test_that("Get magrittr lhs side value", { get_pipe_call() } - expect_equal({ - mtcars %>% x("cyl") - }, - "mtcars") - expect_equal({ - mtcars %>% subset(cyl == 6) %>% x("cyl") - }, - "mtcars") + expect_equal( + { + mtcars %>% x("cyl") + }, + "mtcars" + ) + expect_equal( + { + mtcars %>% + subset(cyl == 6) %>% + x("cyl") + }, + "mtcars" + ) }) From 80a46a636e0a396e796898857ec5967e9b98604f Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 May 2023 20:33:09 +0530 Subject: [PATCH 16/26] feat: add additional test case for .onLoad() --- tests/testthat/test-pkg-load.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/testthat/test-pkg-load.R b/tests/testthat/test-pkg-load.R index 2a1c0a19..82341de1 100644 --- a/tests/testthat/test-pkg-load.R +++ b/tests/testthat/test-pkg-load.R @@ -8,3 +8,14 @@ test_that(".onLoad: Unset options get initialised on package load with defaults" } ) }) + +test_that(".onLoad: Initialised options are retained and not overwritten", { + skip_if(getOption("testthat_interactive")) + withr::with_options( + list(xportr.df_domain_name = "custom_domain"), + { + expect_no_error(.onLoad()) + expect_equal(getOption("xportr.df_domain_name"), "custom_domain") + } + ) +}) From 019be6811509c8d6559b7d4e8dc076cc0cb55afd Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 May 2023 20:54:04 +0530 Subject: [PATCH 17/26] feat: add missed tests for the xportr utils --- tests/testthat/test-utils-xportr.R | 70 +++++++++++++++++++++++++++--- 1 file changed, 63 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-utils-xportr.R b/tests/testthat/test-utils-xportr.R index 2e202156..527fda84 100644 --- a/tests/testthat/test-utils-xportr.R +++ b/tests/testthat/test-utils-xportr.R @@ -34,15 +34,71 @@ test_that("fmt_labs: the message returns properly formatted labels", { expect_equal(fmt_labs(4:6), "Labels '=4', '=5', and '=6'") }) -test_that("xpt_validate_var_names: ", { - xpt_validate_var_names(c("A", "Bajskflas", "2klsd", "asdf_asdf")) - expect_equal(1, 1) +test_that("xpt_validate_var_names: Get error message when the variable is over 8 characters", { + expect_equal( + xpt_validate_var_names(c("FOO", "BAR", "ABCDEFGHI")), + "Variable `ABCDEFGHI` must be 8 characters or less." + ) +}) + +test_that("xpt_validate_var_names: Get error message when the variable does not start with a letter", { + expect_equal( + xpt_validate_var_names(c("FOO", "2BAR")), + "Variable `2BAR` must start with a letter." + ) }) -test_that("xpt_validate", { +test_that("xpt_validate_var_names: Get error message when the variable contains non-ASCII characters or underscore", { + expect_equal( + xpt_validate_var_names(c("FOO", "BAR", "FOO-BAR")), + c( + "Variable `FOO-BAR` cannot contain any non-ASCII, symbol or underscore characters.", + "Variable `FOO-BAR` cannot contain any lowercase characters." + ) + ) + expect_equal( + xpt_validate_var_names(c("FOO", "BAR", "FOO_BAR")), + c( + "Variable `FOO_BAR` cannot contain any non-ASCII, symbol or underscore characters.", + "Variable `FOO_BAR` cannot contain any lowercase characters." + ) + ) +}) + +test_that("xpt_validate_var_names: Get error message when tje variable contains lowercase character", { + xpt_validate_var_names(c("FOO", "bar")) + expect_equal( + xpt_validate_var_names(c("FOO", "bar")), + "Variable `bar` cannot contain any lowercase characters." + ) +}) + +test_that("xpt_validate: Get error message when the label contains non-ASCII, symbol or special characters", { + df <- data.frame(A = 1, B = 2) + attr(df$A, "label") <- "foo Date: Tue, 2 May 2023 21:13:23 +0530 Subject: [PATCH 18/26] Update tests/testthat/test-type.R Co-authored-by: Ben Straub --- tests/testthat/test-type.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R index acab855a..759f2060 100644 --- a/tests/testthat/test-type.R +++ b/tests/testthat/test-type.R @@ -11,7 +11,7 @@ df <- data.frame( Param = c("param1", "param2", "param3") ) -test_that("variable types are coerced as expected and can raise messages", { +test_that("xportr_type: Variable types are coerced as expected and can raise messages", { expect_message( df2 <- xportr_type(df, meta_example), "-- Variable type mismatches found. --" From 06203de63a1dd78b9135f6972f7fe443039429d5 Mon Sep 17 00:00:00 2001 From: Vedha Viyash <49812166+vedhav@users.noreply.github.com> Date: Tue, 2 May 2023 21:13:30 +0530 Subject: [PATCH 19/26] Update tests/testthat/test-type.R Co-authored-by: Ben Straub --- tests/testthat/test-type.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R index 759f2060..f554f6bb 100644 --- a/tests/testthat/test-type.R +++ b/tests/testthat/test-type.R @@ -37,7 +37,7 @@ test_that("xportr_type: Variable types are coerced as expected and can raise mes )) }) -test_that("xportr_type() retains column attributes, besides class", { +test_that("xportr_type: Variables retain column attributes, besides class", { adsl <- dplyr::tibble( USUBJID = c(1001, 1002, 1003), SITEID = c(001, 002, 003), From 91285f07ec4a42142ded872a6d3fa7c25e53e820 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 May 2023 21:25:29 +0530 Subject: [PATCH 20/26] chore: fix lint errors --- tests/testthat/test-utils-xportr.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test-utils-xportr.R b/tests/testthat/test-utils-xportr.R index 527fda84..291a4d73 100644 --- a/tests/testthat/test-utils-xportr.R +++ b/tests/testthat/test-utils-xportr.R @@ -101,4 +101,3 @@ test_that("xpt_validate: Get error message when the variable type is invalid", { "Variables `A` and `B` must have a valid type." ) }) - From 5a4e1a2a2858e592266fb27c2bcb7dce85ac1d42 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 4 May 2023 20:33:41 +0530 Subject: [PATCH 21/26] chore: update namespace --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index e7025ce5..9b83ed5f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,7 +21,6 @@ importFrom(cli,cli_alert_success) importFrom(cli,cli_div) importFrom(cli,cli_h2) importFrom(cli,cli_text) -importFrom(dplyr,all_of) importFrom(dplyr,arrange) importFrom(dplyr,bind_cols) importFrom(dplyr,case_when) From c15dd701555645f324b652442bdca751d94fddbe Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 9 May 2023 05:49:43 +0530 Subject: [PATCH 22/26] feat: adding CI for checking the style of the package --- .github/workflows/check-standard.yaml | 4 +-- .github/workflows/lint.yaml | 6 ++-- .github/workflows/pkgdown.yaml | 4 +-- .github/workflows/spellcheck.yml | 3 +- .github/workflows/style.yml | 45 +++++++++++++++++++++++++++ .github/workflows/test-coverage.yaml | 4 +-- 6 files changed, 55 insertions(+), 11 deletions(-) create mode 100644 .github/workflows/style.yml diff --git a/.github/workflows/check-standard.yaml b/.github/workflows/check-standard.yaml index 07026974..d9d55cb3 100644 --- a/.github/workflows/check-standard.yaml +++ b/.github/workflows/check-standard.yaml @@ -1,13 +1,13 @@ # Workflow derived from https://github.com/r-lib/actions/tree/master/examples # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +name: R-CMD-check ๐Ÿ“ฆ + on: push: branches: [main, devel] pull_request: branches: [main, devel] -name: R-CMD-check - jobs: R-CMD-check: runs-on: ${{ matrix.config.os }} diff --git a/.github/workflows/lint.yaml b/.github/workflows/lint.yaml index ca69bc6c..cee715dc 100644 --- a/.github/workflows/lint.yaml +++ b/.github/workflows/lint.yaml @@ -1,13 +1,13 @@ # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +name: Check Lint ๐Ÿงน + on: push: branches: [main] pull_request: branches: [main, devel] -name: lint - jobs: lint: runs-on: ubuntu-latest @@ -29,4 +29,4 @@ jobs: run: lintr::lint_package() shell: Rscript {0} env: - LINTR_ERROR_ON_LINT: true \ No newline at end of file + LINTR_ERROR_ON_LINT: true diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 781a07e2..5162a56e 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -1,11 +1,11 @@ +name: Deploy pkgdown site ๐Ÿ“œ + on: push: branches: - main - master -name: pkgdown - jobs: pkgdown: runs-on: macOS-latest diff --git a/.github/workflows/spellcheck.yml b/.github/workflows/spellcheck.yml index d738f97f..76c40c78 100644 --- a/.github/workflows/spellcheck.yml +++ b/.github/workflows/spellcheck.yml @@ -1,5 +1,4 @@ ---- -name: Spelling ๐Ÿ†Ž +name: Check Spelling ๐Ÿ†Ž on: workflow_dispatch: diff --git a/.github/workflows/style.yml b/.github/workflows/style.yml new file mode 100644 index 00000000..e220e81a --- /dev/null +++ b/.github/workflows/style.yml @@ -0,0 +1,45 @@ +name: Check Style ๐ŸŽจ + +on: + push: + branches: [main] + pull_request: + branches: [main, devel] + +concurrency: + group: style-${{ github.event.pull_request.number || github.ref }} + cancel-in-progress: true + +jobs: + style: + name: Check code style ๐Ÿง‘โ€๐ŸŽจ + runs-on: ubuntu-latest + if: > + !contains(github.event.commits[0].message, '[skip stylecheck]') + && github.event.pull_request.draft == false + + steps: + - uses: actions/checkout@v3 + with: + path: ${{ github.event.repository.name }} + fetch-depth: 0 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - name: Install styler ๐Ÿ–Œ๏ธ + run: install.packages(c("styler", "knitr"), repos = "https://cloud.r-project.org") + shell: Rscript {0} + + - name: Run styler ๐Ÿ–ผ๏ธ + run: | + detect <- styler::style_pkg(dry = "on") + if (TRUE %in% detect$changed) { + problems <- subset(detect$file, detect$changed == T) + cat(paste("Styling errors found in", length(problems), "files\n")) + cat("Please run `styler::style_pkg()` to fix the style\n") + quit(status = 1) + } + shell: Rscript {0} + working-directory: ${{ github.event.repository.name }} diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 05aee9b4..21398d21 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -1,3 +1,5 @@ +name: Check Test Coverage ๐Ÿงช + on: push: branches: @@ -8,8 +10,6 @@ on: - main - master -name: test-coverage - jobs: test-coverage: runs-on: macOS-latest From 899ade3a6bdd199a5384a4e472aa9378197b5e6f Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 9 May 2023 05:56:27 +0530 Subject: [PATCH 23/26] fix style change --- R/df_label.R | 4 +- R/format.R | 9 +-- R/label.R | 16 +++-- R/length.R | 12 ++-- R/messages.R | 18 ++---- R/order.R | 4 +- R/support-test.R | 39 ++++++------ R/type.R | 35 ++++++----- R/utils-xportr.R | 112 ++++++++++++++++++++------------- R/write.R | 12 ++-- R/xportr-package.R | 8 ++- R/zzz.R | 2 +- README.Rmd | 9 ++- tests/testthat/test-length.R | 3 +- tests/testthat/test-messages.R | 2 +- tests/testthat/test-options.R | 4 +- tests/testthat/test-pipe.R | 20 ++++-- vignettes/xportr.Rmd | 15 +++-- 18 files changed, 179 insertions(+), 145 deletions(-) diff --git a/R/df_label.R b/R/df_label.R index 18899604..3ecf3153 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -27,7 +27,6 @@ #' #' adsl <- xportr_df_label(adsl, metacore) xportr_df_label <- function(.df, metacore, domain = NULL) { - domain_name <- getOption("xportr.df_domain_name") label_name <- getOption("xportr.df_label") @@ -39,8 +38,9 @@ xportr_df_label <- function(.df, metacore, domain = NULL) { ## End of common section - if (inherits(metacore, "Metacore")) + if (inherits(metacore, "Metacore")) { metacore <- metacore$ds_spec + } label <- metacore %>% filter(!!sym(domain_name) == domain) %>% diff --git a/R/format.R b/R/format.R index c874fe7e..e55b7753 100644 --- a/R/format.R +++ b/R/format.R @@ -28,7 +28,6 @@ #' #' adsl <- xportr_format(adsl, metacore) xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.format_verbose", "none")) { - domain_name <- getOption("xportr.domain_name") format_name <- getOption("xportr.format_name") variable_name <- getOption("xportr.variable_name") @@ -41,8 +40,9 @@ xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xpo ## End of common section - if (inherits(metacore, "Metacore")) + if (inherits(metacore, "Metacore")) { metacore <- metacore$var_spec + } if (domain_name %in% names(metacore)) { metadata <- metacore %>% @@ -56,7 +56,7 @@ xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xpo format <- filtered_metadata %>% - select(!!sym(format_name)) %>% + select(!!sym(format_name)) %>% unlist() %>% toupper() @@ -64,8 +64,9 @@ xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xpo for (i in seq_len(ncol(.df))) { format_sas <- purrr::pluck(format, colnames(.df)[i]) - if (is.na(format_sas) || is.null(format_sas)) + if (is.na(format_sas) || is.null(format_sas)) { format_sas <- "" + } attr(.df[[i]], "format.sas") <- format_sas } diff --git a/R/label.R b/R/label.R index f125569e..add71703 100644 --- a/R/label.R +++ b/R/label.R @@ -31,7 +31,6 @@ #' adsl <- xportr_label(adsl, metacore) xportr_label <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.label_verbose", "none")) { - domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") variable_label <- getOption("xportr.label") @@ -44,8 +43,9 @@ xportr_label <- function(.df, metacore, domain = NULL, ## End of common section - if (inherits(metacore, "Metacore")) + if (inherits(metacore, "Metacore")) { metacore <- metacore$var_spec + } if (domain_name %in% names(metacore)) { metadata <- metacore %>% @@ -65,18 +65,22 @@ xportr_label <- function(.df, metacore, domain = NULL, # Check any variable label have more than 40 characters --- label_len <- lapply(label, nchar) - err_len <- which(label_len > 40) %>% names + err_len <- which(label_len > 40) %>% names() if (length(err_len) > 0) { warn( c("Length of variable label must be 40 characters or less.", - x = glue("Problem with {encode_vars(err_len)}.")) + x = glue("Problem with {encode_vars(err_len)}.") + ) ) } for (i in names(.df)) { - if (i %in% miss_vars) attr(.df[[i]], "label") <- "" - else attr(.df[[i]], "label") <- label[[i]] + if (i %in% miss_vars) { + attr(.df[[i]], "label") <- "" + } else { + attr(.df[[i]], "label") <- label[[i]] + } } .df diff --git a/R/length.R b/R/length.R index 5a9966d7..89c39a3f 100644 --- a/R/length.R +++ b/R/length.R @@ -29,7 +29,6 @@ #' adsl <- xportr_length(adsl, metacore) xportr_length <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.length_verbose", "none")) { - domain_name <- getOption("xportr.domain_name") variable_length <- getOption("xportr.length") variable_name <- getOption("xportr.variable_name") @@ -42,8 +41,9 @@ xportr_length <- function(.df, metacore, domain = NULL, ## End of common section - if (inherits(metacore, "Metacore")) + if (inherits(metacore, "Metacore")) { metacore <- metacore$var_spec + } if (domain_name %in% names(metacore)) { metadata <- metacore %>% @@ -67,7 +67,6 @@ xportr_length <- function(.df, metacore, domain = NULL, } else { attr(.df[[i]], "width") <- length[[i]] } - } .df @@ -76,6 +75,9 @@ xportr_length <- function(.df, metacore, domain = NULL, impute_length <- function(col) { characterTypes <- getOption("xportr.character_types") # first_class will collapse to character if it is the option - if (first_class(col) %in% "character") 200 - else 8 + if (first_class(col) %in% "character") { + 200 + } else { + 8 + } } diff --git a/R/messages.R b/R/messages.R index 37d0b9a4..b7b4d376 100644 --- a/R/messages.R +++ b/R/messages.R @@ -10,9 +10,7 @@ #' @return Output to Console #' @export xportr_logger <- function(message, type = "none", ...) { - - log_fun <- switch( - type, + log_fun <- switch(type, stop = abort, warn = warn, message = inform, @@ -20,7 +18,6 @@ xportr_logger <- function(message, type = "none", ...) { ) do.call(log_fun, list(message, ...)) - } #' Utility for Renaming Variables @@ -31,7 +28,6 @@ xportr_logger <- function(message, type = "none", ...) { #' @return Output to Console #' @export var_names_log <- function(tidy_names_df, verbose) { - only_renames <- tidy_names_df %>% filter(original_varname != renamed_var) %>% mutate( @@ -53,7 +49,7 @@ var_names_log <- function(tidy_names_df, verbose) { # Message stating any renamed variables each original variable and it's new name if (nrow(only_renames) > 0) { - walk(only_renames$renamed_msg, ~xportr_logger(.x, verbose)) + walk(only_renames$renamed_msg, ~ xportr_logger(.x, verbose)) } # Message checking for duplicate variable names after renamed (Pretty sure @@ -80,9 +76,7 @@ var_names_log <- function(tidy_names_df, verbose) { #' @return Output to Console #' @export type_log <- function(meta_ordered, type_mismatch_ind, verbose) { - if (length(type_mismatch_ind) > 0) { - message <- glue( "Variable type(s) in dataframe don't match metadata: ", "{encode_vars(meta_ordered[type_mismatch_ind, 'variable'])}" @@ -103,9 +97,7 @@ type_log <- function(meta_ordered, type_mismatch_ind, verbose) { #' @return Output to Console #' @export length_log <- function(miss_vars, verbose) { - if (length(miss_vars) > 0) { - cli_h2("Variable lengths missing from metadata.") cli_alert_success("{ length(miss_vars) } lengths resolved") @@ -127,15 +119,14 @@ length_log <- function(miss_vars, verbose) { #' @return Output to Console #' @export label_log <- function(miss_vars, verbose) { - if (length(miss_vars) > 0) { - cli_h2("Variable labels missing from metadata.") cli_alert_success("{ length(miss_vars) } labels skipped") xportr_logger( c("Variable(s) present in dataframe but doesn't exist in `metadata`.", - x = glue("Problem with {encode_vars(miss_vars)}")), + x = glue("Problem with {encode_vars(miss_vars)}") + ), type = verbose ) } @@ -149,7 +140,6 @@ label_log <- function(miss_vars, verbose) { #' @return Output to Console #' @export var_ord_msg <- function(moved_vars, verbose) { - if (length(moved_vars) > 0) { cli_h2("{ length(moved_vars) } variables not in spec and moved to end") message <- glue( diff --git a/R/order.R b/R/order.R index a388e243..19303028 100644 --- a/R/order.R +++ b/R/order.R @@ -25,7 +25,6 @@ #' #' adsl <- xportr_order(adsl, metacore) xportr_order <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.order_verbose", "none")) { - domain_name <- getOption("xportr.domain_name") order_name <- getOption("xportr.order_name") variable_name <- getOption("xportr.variable_name") @@ -38,8 +37,9 @@ xportr_order <- function(.df, metacore, domain = NULL, verbose = getOption("xpor ## End of common section - if (inherits(metacore, "Metacore")) + if (inherits(metacore, "Metacore")) { metacore <- metacore$ds_vars + } if (domain_name %in% names(metacore)) { metadata <- metacore %>% diff --git a/R/support-test.R b/R/support-test.R index ce4c9387..deba9587 100644 --- a/R/support-test.R +++ b/R/support-test.R @@ -7,11 +7,13 @@ #' @return The first argument, invisibly. expect_attr_width <- function(result, metadata_length) { test_widths <- map( - colnames(result), ~attributes(result[[.x]]) %>% pluck("width") + colnames(result), ~ attributes(result[[.x]]) %>% pluck("width") ) %>% unlist() == metadata_length - test_widths %>% all() %>% testthat::expect_true() + test_widths %>% + all() %>% + testthat::expect_true() invisible(result) } @@ -67,29 +69,28 @@ minimal_table <- function(n_rows = 3, cols = c("x", "y")) { #' #' @return A metadata data.frame minimal_metadata <- function( - dataset = FALSE, - length = FALSE, - label = FALSE, - type = FALSE, - format = FALSE, - order = FALSE, - dataset_name = "adsl", - var_names = NULL -) { + dataset = FALSE, + length = FALSE, + label = FALSE, + type = FALSE, + format = FALSE, + order = FALSE, + dataset_name = "adsl", + var_names = NULL) { cols_logical <- c(dataset, TRUE, label, length, type, format, order) cols <- c( "dataset", "variable", "label", "length", "type", "format", "order" )[cols_logical] metadata <- tribble( - ~dataset, ~variable, ~label, ~length, ~type, ~format, ~order, - "adsl", "x", "Lorem", 8, "numeric", NA, 1, - "adsl", "y", "Ipsum", 200, "numeric", NA, 2, - "adsl", "z", "Dolor", 8, "numeric", NA, 3, - "adsl", "a", "Sit", 8, "numeric", NA, 4, - "adsl", "b", "Amet", 200, "character", NA, 5, - "adsl", "c", "Consectetur", 200, "character", "datetime20.", 6, - "adsl", "d", "Adipiscing", 200, "date", "date9.", 7 + ~dataset, ~variable, ~label, ~length, ~type, ~format, ~order, + "adsl", "x", "Lorem", 8, "numeric", NA, 1, + "adsl", "y", "Ipsum", 200, "numeric", NA, 2, + "adsl", "z", "Dolor", 8, "numeric", NA, 3, + "adsl", "a", "Sit", 8, "numeric", NA, 4, + "adsl", "b", "Amet", 200, "character", NA, 5, + "adsl", "c", "Consectetur", 200, "character", "datetime20.", 6, + "adsl", "d", "Adipiscing", 200, "date", "date9.", 7 ) if (!is.null(var_names)) { diff --git a/R/type.R b/R/type.R index 2e465b1f..f680700b 100644 --- a/R/type.R +++ b/R/type.R @@ -24,16 +24,15 @@ #' ) #' #' .df <- data.frame( -#' Subj = as.character(123, 456, 789), -#' Different = c("a", "b", "c"), -#' Val = c("1", "2", "3"), -#' Param = c("param1", "param2", "param3") +#' Subj = as.character(123, 456, 789), +#' Different = c("a", "b", "c"), +#' Val = c("1", "2", "3"), +#' Param = c("param1", "param2", "param3") #' ) #' #' df2 <- xportr_type(.df, metacore, "test") xportr_type <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.type_verbose", "none")) { - # Name of the columns for working with metadata domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") @@ -83,17 +82,21 @@ xportr_type <- function(.df, metacore, domain = NULL, # Walk along the columns and coerce the variables. Modifying the columns # Directly instead of something like map_dfc to preserve any attributes. - walk2(correct_type, seq_along(correct_type), - function(x, i, is_correct) { - if (!is_correct[i]) { - orig_attributes <- attributes(.df[[i]]) - orig_attributes$class <- NULL - if (correct_type[i] %in% characterTypes) - .df[[i]] <<- as.character(.df[[i]]) - else .df[[i]] <<- as.numeric(.df[[i]]) - attributes(.df[[i]]) <<- orig_attributes - } - }, is_correct) + walk2( + correct_type, seq_along(correct_type), + function(x, i, is_correct) { + if (!is_correct[i]) { + orig_attributes <- attributes(.df[[i]]) + orig_attributes$class <- NULL + if (correct_type[i] %in% characterTypes) { + .df[[i]] <<- as.character(.df[[i]]) + } else { + .df[[i]] <<- as.numeric(.df[[i]]) + } + attributes(.df[[i]]) <<- orig_attributes + } + }, is_correct + ) .df } diff --git a/R/utils-xportr.R b/R/utils-xportr.R index 98969649..427a1414 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -9,8 +9,10 @@ extract_attr <- function(data, attr = c("label", "format.sas", "SAStype", "SASle attr <- match.arg(attr) out <- lapply(data, function(.x) attr(.x, attr)) out <- vapply(out, - function(.x) ifelse(is.null(.x), "", .x), - character(1L), USE.NAMES = FALSE) + function(.x) ifelse(is.null(.x), "", .x), + character(1L), + USE.NAMES = FALSE + ) names(out) <- names(data) out } @@ -119,26 +121,29 @@ fmt_fmts <- function(x) { xpt_validate_var_names <- function(varnames, list_vars_first = TRUE, err_cnd = character()) { - # 1.1 Check length -- chk_varlen <- varnames[nchar(varnames) > 8] if (length(chk_varlen) > 0) { err_cnd <- c(err_cnd, ifelse(list_vars_first, - glue("{fmt_vars(chk_varlen)} must be 8 characters or less."), - glue(" - Must be 8 characters or less: {fmt_vars(chk_varlen)}."))) + glue("{fmt_vars(chk_varlen)} must be 8 characters or less."), + glue(" + Must be 8 characters or less: {fmt_vars(chk_varlen)}.") + )) } # 1.2 Check first character -- - chk_first_chr <- varnames[stringr::str_detect(stringr::str_sub(varnames, 1, 1), - "[^[:alpha:]]")] + chk_first_chr <- varnames[stringr::str_detect( + stringr::str_sub(varnames, 1, 1), + "[^[:alpha:]]" + )] if (length(chk_first_chr) > 0) { err_cnd <- c(err_cnd, ifelse(list_vars_first, - glue("{fmt_vars(chk_first_chr)} must start with a letter."), - glue(" - Must start with a letter: {fmt_vars(chk_first_chr)}."))) + glue("{fmt_vars(chk_first_chr)} must start with a letter."), + glue(" + Must start with a letter: {fmt_vars(chk_first_chr)}.") + )) } # 1.3 Check Non-ASCII and underscore characters -- @@ -146,21 +151,24 @@ xpt_validate_var_names <- function(varnames, if (length(chk_alnum) > 0) { err_cnd <- c(err_cnd, ifelse(list_vars_first, - glue("{fmt_vars(chk_alnum)} cannot contain any non-ASCII, symbol or underscore characters."), - glue(" - Cannot contain any non-ASCII, symbol or underscore characters: {fmt_vars(chk_alnum)}."))) + glue("{fmt_vars(chk_alnum)} cannot contain any non-ASCII, symbol or underscore characters."), + glue(" + Cannot contain any non-ASCII, symbol or underscore characters: {fmt_vars(chk_alnum)}.") + )) } # 1.4 Check for any lowercase letters - or not all uppercase chk_lower <- varnames[!stringr::str_detect( - stringr::str_replace_all(varnames, "[:digit:]", ""), - "^[[:upper:]]+$")] + stringr::str_replace_all(varnames, "[:digit:]", ""), + "^[[:upper:]]+$" + )] if (length(chk_lower) > 0) { err_cnd <- c(err_cnd, ifelse(list_vars_first, - glue("{fmt_vars(chk_lower)} cannot contain any lowercase characters."), - glue(" - Cannot contain any lowercase characters {fmt_vars(chk_lower)}."))) + glue("{fmt_vars(chk_lower)} cannot contain any lowercase characters."), + glue(" + Cannot contain any lowercase characters {fmt_vars(chk_lower)}.") + )) } return(err_cnd) } @@ -172,7 +180,6 @@ xpt_validate_var_names <- function(varnames, #' @return xpt file #' @noRd xpt_validate <- function(data) { - err_cnd <- character() # 1.0 VARIABLES ---- @@ -187,45 +194,55 @@ xpt_validate <- function(data) { chk_label_len <- labels[nchar(labels) > 40] if (length(chk_label_len) > 0) { - err_cnd <- c(err_cnd, - glue("{fmt_labs(chk_label_len)} must be 40 characters or less.")) + err_cnd <- c( + err_cnd, + glue("{fmt_labs(chk_label_len)} must be 40 characters or less.") + ) } # 2.2 Check Non-ASCII and special characters chk_spl_chr <- labels[stringr::str_detect(labels, "[<>]|[^[:ascii:]]")] if (length(chk_spl_chr) > 0) { - err_cnd <- c(err_cnd, - glue("{fmt_labs(chk_spl_chr)} cannot contain any non-ASCII, symbol or special characters.")) + err_cnd <- c( + err_cnd, + glue("{fmt_labs(chk_spl_chr)} cannot contain any non-ASCII, symbol or special characters.") + ) } # 3.0 VARIABLE TYPES ---- types <- tolower(extract_attr(data, attr = "SAStype")) - expected_types <- c("", "text", "integer", "float", "datetime", "date", "time", - "partialdate", "partialtime", "partialdatetime", - "incompletedatetime", "durationdatetime", "intervaldatetime") + expected_types <- c( + "", "text", "integer", "float", "datetime", "date", "time", + "partialdate", "partialtime", "partialdatetime", + "incompletedatetime", "durationdatetime", "intervaldatetime" + ) # 3.1 Invalid types -- chk_types <- types[which(!types %in% expected_types)] if (length(chk_types) > 0) { - err_cnd <- c(err_cnd, - glue("{fmt_vars(names(types))} must have a valid type.")) + err_cnd <- c( + err_cnd, + glue("{fmt_vars(names(types))} must have a valid type.") + ) } # 4.0 Format Types ---- formats <- tolower(extract_attr(data, attr = "format.sas")) ## The usual expected formats in clinical trials: characters, dates - expected_formats <- c(NA, - "", - paste("$", 1:200, ".", sep = ""), - paste("date", 5:11, ".", sep = ""), - paste("time", 2:20, ".", sep = ""), - paste("datetime", 7:40, ".", sep = ""), - paste("yymmdd", 2:10, ".", sep = ""), - paste("mmddyy", 2:10, ".", sep = ""), - paste("ddmmyy", 2:10, ".", sep = "")) + expected_formats <- c( + NA, + "", + paste("$", 1:200, ".", sep = ""), + paste("date", 5:11, ".", sep = ""), + paste("time", 2:20, ".", sep = ""), + paste("datetime", 7:40, ".", sep = ""), + paste("yymmdd", 2:10, ".", sep = ""), + paste("mmddyy", 2:10, ".", sep = ""), + paste("ddmmyy", 2:10, ".", sep = "") + ) chk_formats <- formats[which(!formats %in% expected_formats)] @@ -233,8 +250,10 @@ xpt_validate <- function(data) { format_regex <- "^([1-9]|[12][0-9]|3[0-2])\\.$|^([1-9]|[12][0-9]|3[0-2])\\.([1-9]|[12][0-9]|3[0-1])$" chk_formats <- chk_formats[which(!str_detect(chk_formats, format_regex))] if (length(chk_formats) > 0) { - err_cnd <- c(err_cnd, - glue("{fmt_fmts(names(chk_formats))} must have a valid format.")) + err_cnd <- c( + err_cnd, + glue("{fmt_fmts(names(chk_formats))} must have a valid format.") + ) } return(err_cnd) } @@ -246,8 +265,8 @@ xpt_validate <- function(data) { get_domain <- function(.df, df_arg, domain) { if (!is.null(domain) && !is.character(domain)) { abort(c("`domain` must be a vector with type .", - x = glue("Instead, it has type <{typeof(domain)}>.")) - ) + x = glue("Instead, it has type <{typeof(domain)}>.") + )) } if (identical(df_arg, ".")) { @@ -262,7 +281,7 @@ get_domain <- function(.df, df_arg, domain) { #' @return The R Object at the top of a pipe stack #' @noRd get_pipe_call <- function() { - call_strs <- map(as.list(sys.calls()), ~deparse1(.x, nlines = 1)) + call_strs <- map(as.list(sys.calls()), ~ deparse1(.x, nlines = 1)) top_call <- max(which(str_detect(call_strs, "%>%"))) call_str <- call_strs[[top_call]] trimws(strsplit(call_str, "%>%", fixed = TRUE)[[1]][[1]]) @@ -277,6 +296,9 @@ get_pipe_call <- function() { first_class <- function(x) { characterTypes <- getOption("xportr.character_types") class_ <- tolower(class(x)[1]) - if (class_ %in% characterTypes) "character" - else class_ + if (class_ %in% characterTypes) { + "character" + } else { + class_ + } } diff --git a/R/write.R b/R/write.R index 2bca7e39..369db5c4 100644 --- a/R/write.R +++ b/R/write.R @@ -20,9 +20,8 @@ #' @return A data frame. `xportr_write()` returns the input data invisibly. #' @export xportr_write <- function(.df, path, label = NULL) { - path <- normalizePath(path, mustWork = FALSE) - + name <- tools::file_path_sans_ext(basename(path)) if (nchar(name) > 8) { @@ -34,16 +33,17 @@ xportr_write <- function(.df, path, label = NULL) { } if (!is.null(label)) { - - if (nchar(label) > 40) + if (nchar(label) > 40) { abort("`label` must be 40 characters or less.") + } - if (stringr::str_detect(label, "[<>]|[^[:ascii:]]")) + if (stringr::str_detect(label, "[<>]|[^[:ascii:]]")) { abort("`label` cannot contain any non-ASCII, symbol or special characters.") + } attr(.df, "label") <- label } - + checks <- xpt_validate(.df) if (length(checks) > 0) { diff --git a/R/xportr-package.R b/R/xportr-package.R index 5d86b2d4..09e63f42 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -23,9 +23,11 @@ #' "_PACKAGE" -globalVariables(c("abbr_parsed", "abbr_stem", "adj_orig", "adj_parsed", "col_pos", "dict_varname", - "lower_original_varname", "my_minlength", "num_st_ind", "original_varname", - "renamed_n", "renamed_var", "use_bundle", "viable_start")) +globalVariables(c( + "abbr_parsed", "abbr_stem", "adj_orig", "adj_parsed", "col_pos", "dict_varname", + "lower_original_varname", "my_minlength", "num_st_ind", "original_varname", + "renamed_n", "renamed_var", "use_bundle", "viable_start" +)) # The following block is used by usethis to automatically manage # roxygen namespace tags. Modify with care! diff --git a/R/zzz.R b/R/zzz.R index 35eca269..4cb85dde 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -19,6 +19,6 @@ ) toset <- !(names(op.devtools) %in% names(op)) if (any(toset)) options(op.devtools[toset]) - + invisible() } diff --git a/README.Rmd b/README.Rmd index da78786c..feef6bc7 100644 --- a/README.Rmd +++ b/README.Rmd @@ -123,18 +123,17 @@ spec_path <- system.file(paste0("specs/", "ADaM_admiral_spec.xlsx"), package = " var_spec <- readxl::read_xlsx(spec_path, sheet = "Variables") %>% dplyr::rename(type = "Data Type") %>% rlang::set_names(tolower) - ``` Each `xportr_` function has been written in a way to take in a part of the specification file and apply that piece to the dataset. ```{r, message=FALSE, eval=FALSE} -adsl %>% +adsl %>% xportr_type(var_spec, "ADSL") %>% xportr_length(var_spec, "ADSL") %>% xportr_label(var_spec, "ADSL") %>% - xportr_order(var_spec, "ADSL") %>% - xportr_format(var_spec, "ADSL") %>% + xportr_order(var_spec, "ADSL") %>% + xportr_format(var_spec, "ADSL") %>% xportr_write("adsl.xpt", label = "Subject-Level Analysis Dataset") ``` @@ -146,4 +145,4 @@ We are in talks with other Pharma companies involved with the [`{pharmaverse}`](
-This package was developed jointly by [GSK](https://us.gsk.com/en-us/home/) and [Atorus](https://www.atorusresearch.com/). \ No newline at end of file +This package was developed jointly by [GSK](https://us.gsk.com/en-us/home/) and [Atorus](https://www.atorusresearch.com/). diff --git a/tests/testthat/test-length.R b/tests/testthat/test-length.R index 52561888..062b2b59 100644 --- a/tests/testthat/test-length.R +++ b/tests/testthat/test-length.R @@ -124,7 +124,7 @@ test_that("xportr_length: Impute character lengths based on class", { adsl <- adsl %>% mutate( new_date = as.Date(.data$x, origin = "1970-01-01"), - new_char = as.character(.data$b), + new_char = as.character(.data$b), new_num = as.numeric(.data$x) ) @@ -211,5 +211,4 @@ test_that("xportr_length: Column length of known/unkown character types is 200/8 withr::local_options(list(xportr.character_types = c("character", "date"))) expect_equal(impute_length(Sys.time()), 8) - }) diff --git a/tests/testthat/test-messages.R b/tests/testthat/test-messages.R index 0a82f239..36c35b32 100644 --- a/tests/testthat/test-messages.R +++ b/tests/testthat/test-messages.R @@ -85,7 +85,7 @@ test_that("var_names_log: Renamed variables messages are shown", { var_names_log("message") %>% expect_message( ".*[0-9]+ of [0-9]+ \\([0-9]+(\\.[0-9]+)%\\) variables were renamed.*" - ) %>% + ) %>% expect_message("Var . : '.*' was renamed to '.*'") %>% expect_message("Var . : '.*' was renamed to '.*'") %>% expect_message("Var . : '.*' was renamed to '.*'") %>% diff --git a/tests/testthat/test-options.R b/tests/testthat/test-options.R index 9592f9f0..8a845c88 100644 --- a/tests/testthat/test-options.R +++ b/tests/testthat/test-options.R @@ -1,6 +1,6 @@ test_that("options are originally set as expected", { op <- options() - + expect_equal(op$xportr.df_domain_name, "dataset") expect_equal(op$xportr.df_label, "label") expect_equal(op$xportr.coerse, "none") @@ -10,6 +10,4 @@ test_that("options are originally set as expected", { expect_equal(op$xportr.label, "label") expect_equal(op$xportr.length, "length") expect_equal(op$xportr.format_name, "format") - - }) diff --git a/tests/testthat/test-pipe.R b/tests/testthat/test-pipe.R index 4adb4bf0..cc842266 100644 --- a/tests/testthat/test-pipe.R +++ b/tests/testthat/test-pipe.R @@ -6,11 +6,21 @@ test_that("xportr_*: Domain is obtained from a call without pipe", { order = TRUE ) - xportr_label(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") - xportr_length(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") - xportr_order(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") - xportr_format(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") - xportr_type(adsl, metadata) %>% attr("_xportr.df_arg_") %>% expect_equal("adsl") + xportr_label(adsl, metadata) %>% + attr("_xportr.df_arg_") %>% + expect_equal("adsl") + xportr_length(adsl, metadata) %>% + attr("_xportr.df_arg_") %>% + expect_equal("adsl") + xportr_order(adsl, metadata) %>% + attr("_xportr.df_arg_") %>% + expect_equal("adsl") + xportr_format(adsl, metadata) %>% + attr("_xportr.df_arg_") %>% + expect_equal("adsl") + xportr_type(adsl, metadata) %>% + attr("_xportr.df_arg_") %>% + expect_equal("adsl") }) diff --git a/vignettes/xportr.Rmd b/vignettes/xportr.Rmd index 2c98eb41..001edc74 100644 --- a/vignettes/xportr.Rmd +++ b/vignettes/xportr.Rmd @@ -23,10 +23,12 @@ library(DT) local({ hook_output <- knitr::knit_hooks$get("output") knitr::knit_hooks$set(output = function(x, options) { - if (!is.null(options$max.height)) options$attr.output <- c( - options$attr.output, - sprintf('style="max-height: %s;"', options$max.height) - ) + if (!is.null(options$max.height)) { + options$attr.output <- c( + options$attr.output, + sprintf('style="max-height: %s;"', options$max.height) + ) + } hook_output(x, options) }) }) @@ -90,10 +92,11 @@ In order to make use of the functions within `xportr` you will need to create an ```{r} var_spec <- readxl::read_xlsx( - system.file(paste0("specs/", "ADaM_admiral_spec.xlsx"), package = "xportr"), sheet = "Variables") %>% + system.file(paste0("specs/", "ADaM_admiral_spec.xlsx"), package = "xportr"), + sheet = "Variables" +) %>% dplyr::rename(type = "Data Type") %>% rlang::set_names(tolower) - ```
From 2b456477291cb5062ac849b221d235c47f7d6412 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 9 May 2023 06:14:00 +0530 Subject: [PATCH 24/26] chore: update document --- man/xportr_type.Rd | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/man/xportr_type.Rd b/man/xportr_type.Rd index 979028e3..7c82ff13 100644 --- a/man/xportr_type.Rd +++ b/man/xportr_type.Rd @@ -40,10 +40,10 @@ metacore <- data.frame( ) .df <- data.frame( - Subj = as.character(123, 456, 789), - Different = c("a", "b", "c"), - Val = c("1", "2", "3"), - Param = c("param1", "param2", "param3") + Subj = as.character(123, 456, 789), + Different = c("a", "b", "c"), + Val = c("1", "2", "3"), + Param = c("param1", "param2", "param3") ) df2 <- xportr_type(.df, metacore, "test") From cde9b3b17544fed2622605967428700050e2566e Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 9 May 2023 10:41:22 +0530 Subject: [PATCH 25/26] fix: adding roxygen2 dependency to avoid styler warnings --- .github/workflows/style.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/style.yml b/.github/workflows/style.yml index e220e81a..fc779f37 100644 --- a/.github/workflows/style.yml +++ b/.github/workflows/style.yml @@ -29,7 +29,7 @@ jobs: use-public-rspm: true - name: Install styler ๐Ÿ–Œ๏ธ - run: install.packages(c("styler", "knitr"), repos = "https://cloud.r-project.org") + run: install.packages(c("styler", "knitr", "roxygen2"), repos = "https://cloud.r-project.org") shell: Rscript {0} - name: Run styler ๐Ÿ–ผ๏ธ From cdceb9c6a84d0934d64aba42c7caf95eebdb51fc Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 9 May 2023 12:04:20 +0530 Subject: [PATCH 26/26] fix: ignoring the functions that are intended for internal use --- _pkgdown.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index f679d7a1..cac53b0e 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -33,3 +33,9 @@ reference: contents: - xportr +- title: internal + contents: + - cli_theme_tests + - expect_attr_width + - minimal_metadata + - minimal_table