From d51bdd7388b18df447b31dd08fae90926fb350e5 Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Thu, 22 Feb 2024 00:39:28 -0500 Subject: [PATCH 1/9] Closes #223 Test code clean up --- man/metadata.Rd | 2 +- man/xportr_df_label.Rd | 2 +- man/xportr_format.Rd | 2 +- man/xportr_label.Rd | 2 +- man/xportr_length.Rd | 2 +- man/xportr_order.Rd | 2 +- man/xportr_type.Rd | 2 +- man/xportr_write.Rd | 2 +- tests/testthat/test-metadata.R | 2 +- tests/testthat/test-xportr.R | 2 +- 10 files changed, 10 insertions(+), 10 deletions(-) diff --git a/man/metadata.Rd b/man/metadata.Rd index 9df1c6c8..30918a0c 100644 --- a/man/metadata.Rd +++ b/man/metadata.Rd @@ -12,7 +12,7 @@ xportr_metadata(.df, metadata = NULL, domain = NULL, verbose = NULL) \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_df_label.Rd b/man/xportr_df_label.Rd index 5f95d771..691de990 100644 --- a/man/xportr_df_label.Rd +++ b/man/xportr_df_label.Rd @@ -12,7 +12,7 @@ xportr_df_label(.df, metadata = NULL, domain = NULL, metacore = deprecated()) \item{metadata}{A data frame containing dataset. See 'Metadata' section for details.} -\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_format.Rd b/man/xportr_format.Rd index 0c00da1b..e085a345 100644 --- a/man/xportr_format.Rd +++ b/man/xportr_format.Rd @@ -12,7 +12,7 @@ xportr_format(.df, metadata = NULL, domain = NULL, metacore = deprecated()) \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_label.Rd b/man/xportr_label.Rd index a61e0583..eb03df81 100644 --- a/man/xportr_label.Rd +++ b/man/xportr_label.Rd @@ -18,7 +18,7 @@ xportr_label( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_length.Rd b/man/xportr_length.Rd index c3180a71..a2c2e01e 100644 --- a/man/xportr_length.Rd +++ b/man/xportr_length.Rd @@ -19,7 +19,7 @@ xportr_length( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_order.Rd b/man/xportr_order.Rd index 03617d4f..26b87f42 100644 --- a/man/xportr_order.Rd +++ b/man/xportr_order.Rd @@ -18,7 +18,7 @@ xportr_order( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_type.Rd b/man/xportr_type.Rd index 05489fcf..736fe0c6 100644 --- a/man/xportr_type.Rd +++ b/man/xportr_type.Rd @@ -18,7 +18,7 @@ xportr_type( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_write.Rd b/man/xportr_write.Rd index bde66844..c6bd4a1d 100644 --- a/man/xportr_write.Rd +++ b/man/xportr_write.Rd @@ -22,7 +22,7 @@ used as \code{xpt} name.} \item{metadata}{A data frame containing dataset. See 'Metadata' section for details.} -\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index 9c9a4d08..900d1b22 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -759,7 +759,7 @@ test_that("xportr_*: Domain is kept in between calls", { # end test_that("`xportr_metadata()` results match traditional results", { - if (require(magrittr, quietly = TRUE)) { + if (requireNamespace("magrittr", quietly = TRUE)) { skip_if_not_installed("withr") trad_path <- withr::local_file("adsltrad.xpt") metadata_path <- withr::local_file("adslmeta.xpt") diff --git a/tests/testthat/test-xportr.R b/tests/testthat/test-xportr.R index 60161a72..c9723aef 100644 --- a/tests/testthat/test-xportr.R +++ b/tests/testthat/test-xportr.R @@ -1,5 +1,5 @@ test_that("pipeline results match `xportr()` results", { - if (require(magrittr, quietly = TRUE)) { + if (requireNamespace("magrittr", quietly = TRUE)) { skip_if_not_installed("withr") pipeline_path <- withr::local_file("adslpipe.xpt") xportr_path <- withr::local_file("adslxptr.xpt") From 9c33499c049af27098c34076092402825cd96924 Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Mon, 4 Mar 2024 11:25:29 -0500 Subject: [PATCH 2/9] removing magrittr where it's not necessary --- tests/testthat/test-metadata.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index e3a59a39..f1cf9228 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -760,8 +760,6 @@ test_that("xportr_*: Domain is kept in between calls", { test_that("`xportr_metadata()` results match traditional results", { - if (requireNamespace("magrittr", quietly = TRUE)) { - data("var_spec", "dataset_spec", "adsl_xportr", envir = environment()) adsl <- adsl_xportr @@ -807,5 +805,5 @@ test_that("`xportr_metadata()` results match traditional results", { haven::read_xpt(metadata_path), haven::read_xpt(trad_path) ) - } + }) From 5d82e22689529734311aa45f744d169bbee33092 Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Wed, 6 Mar 2024 02:20:14 -0500 Subject: [PATCH 3/9] Order test files --- R/addin_format_testthat.R | 107 +++++++ tests/testthat/test-deprecation.R | 94 ++++++ tests/testthat/test-depreciation.R | 72 ----- tests/testthat/test-df_label.R | 3 +- tests/testthat/test-format.R | 27 +- tests/testthat/test-label.R | 55 ++-- tests/testthat/test-length.R | 378 +++++++++++++----------- tests/testthat/test-messages.R | 122 ++++---- tests/testthat/test-metadata.R | 110 ++++--- tests/testthat/test-options.R | 9 +- tests/testthat/test-order.R | 49 +-- tests/testthat/test-pkg-load.R | 6 +- tests/testthat/test-support-for-tests.R | 9 +- tests/testthat/test-type.R | 33 ++- tests/testthat/test-utils-xportr.R | 39 ++- tests/testthat/test-write.R | 45 ++- tests/testthat/test-xportr.R | 7 +- 17 files changed, 713 insertions(+), 452 deletions(-) create mode 100644 R/addin_format_testthat.R create mode 100644 tests/testthat/test-deprecation.R delete mode 100644 tests/testthat/test-depreciation.R diff --git a/R/addin_format_testthat.R b/R/addin_format_testthat.R new file mode 100644 index 00000000..df6c5b0a --- /dev/null +++ b/R/addin_format_testthat.R @@ -0,0 +1,107 @@ +# Returns the call for updating a given test_that test file +# by adding a function name, a test number, and a section. +# Call the function either by using RStudio Addin "format_test_that_file" or +# programmatically in a for loop on the test files and running +# rstudioapi::navigateToFile and format_test_that_file +prepare_test_that_file <- function(path) { + assert_character_scalar(path) + + # check that file exists + if (!file.exists(path)) { + stop("Invalid file path, the file does not exist.") + } + + # check that testthat is used and testing file is opened + uses_test_file <- grepl("tests/testthat/test-", path, fixed = TRUE) + if (!uses_test_file) { + stop("This Addin works only on unit test files that follow a testthat structure.") + } + + # parse the name of the testing function + testing_file <- sub("^test-", "", sub(".R$", "", basename(path))) + + # get file content + file_content <- readLines(path) + + # get locations of tests - match 'test_that("' strings + test_that_loc <- grep('^test_that\\("', file_content) + + if (length(test_that_loc) == 0) { + return(invisible(NULL)) + } + + #### + ## HANDLE test_that DESCRIPTIONS + #### + + # get and parse test descriptions + test_that_lines <- file_content[test_that_loc] + test_that_desc_parsed <- stringr::str_extract( + string = test_that_lines, + pattern = paste0( + '(?<=test_that\\(")', # positive look-ahead - search matching expression after test_that(" + ".*", # matching expression - match everything + '(?=")' # positive look-behind - search matching expression before " + ) + ) + test_that_desc_cleaned <- stringr::str_remove( + string = test_that_desc_parsed, + pattern = paste0("([\\w\\.]+,? )?[Tt]est \\d{1,} ?: ") + ) + + # determine name of function which is tested + # the function name can be specified by # function_name ---- comments + function_name <- str_match(file_content, "# ([\\w\\.]+) ----")[, 2] + if (is.na(function_name[1])) { + function_name[1] <- testing_file + } + function_name <- tidyr::fill(data.frame(name = function_name), name)$name + function_name <- function_name[test_that_loc] + + # formulate new test descriptions (update only those that don't include test_title) + new_desc <- paste0( + "Test ", seq_along(test_that_loc), ": ", + test_that_desc_cleaned + ) + + # insert new test descriptions into test_that lines + test_that_lines_updated <- stringr::str_replace( + string = test_that_lines, + pattern = '(?<=test_that\\(").*"', + replacement = paste0(function_name, " ", new_desc, '"') + ) + + # modify the file content + file_content[test_that_loc] <- test_that_lines_updated + + #### + ## HANDLE HEADERS + #### + + # formulate headers according to RStudio editor functionality + headers <- paste0("## ", new_desc, " ----") + + # get locations of headers created by this function + header_loc_lgl <- grepl(paste0("^##?( ----)?( \\w+)?,? [tT]est \\d{1,} ?: "), file_content) + + # remove those headers + file_content <- file_content[!header_loc_lgl] + + # add new headers just before test_that calls + header_loc <- grep('^test_that\\("', file_content) + seq_along(headers) - 1 + file_content_new <- vector(mode = "character", length = length(file_content) + length(headers)) + file_content_new[header_loc] <- headers + file_content_new[-header_loc] <- file_content + + list(file_content = file_content_new) +} + +# Function for the RStudio Addin, see inst/rstudio/addins.dcf. +# Wrapper of prepare_test_that_file. +format_test_that_file <- function() { + file_info <- rstudioapi::getActiveDocumentContext() + rstudioapi::documentSave(id = file_info$id) + result <- prepare_test_that_file(path = file_info$path) + rstudioapi::setDocumentContents(paste0(result$file_content, collapse = "\n"), id = file_info$id) + rstudioapi::documentSave(id = file_info$id) +} diff --git a/tests/testthat/test-deprecation.R b/tests/testthat/test-deprecation.R new file mode 100644 index 00000000..e3e1f34b --- /dev/null +++ b/tests/testthat/test-deprecation.R @@ -0,0 +1,94 @@ +## Test 1: xportr_df_label: deprecated metacore gives an error ---- +test_that("deprecation Test 1: xportr_df_label: deprecated metacore gives an error", + { + local_options(lifecycle_verbosity = "quiet") + df <- data.frame(x = "a", y = "b") + df_meta <- data.frame(dataset = "df", label = "Label") + + expect_error(xportr_df_label(df, metacore = df_meta)) + }) + +## Test 2: xportr_format: deprecated metacore gives an error ---- +test_that("deprecation Test 2: xportr_format: deprecated metacore gives an error", + { + local_options(lifecycle_verbosity = "quiet") + df <- data.frame(x = 1, y = 2) + df_meta <- data.frame(dataset = "df", + variable = "x", + format = "date9.") + + expect_error(xportr_format(df, metacore = df_meta)) + }) + +## Test 3: xportr_label: using the deprecated metacore argument gives an error ---- +test_that( + "deprecation Test 3: xportr_label: using the deprecated metacore argument gives an error", + { + local_options(lifecycle_verbosity = "quiet") + + df <- data.frame(x = "a", y = "b") + df_meta <- + data.frame(dataset = "df", + variable = "x", + label = "foo") + + expect_error(xportr_label(df, metacore = df_meta)) + } +) + +## Test 4: xportr_length: using the deprecated metacore argument gives an error ---- +test_that( + "deprecation Test 4: xportr_length: using the deprecated metacore argument gives an error", + { + local_options(lifecycle_verbosity = "quiet") + df <- data.frame(x = "a", y = "b") + df_meta <- data.frame( + dataset = "df", + variable = c("x", "y"), + type = c("text", "text"), + length = c(1, 2) + ) + + expect_error(xportr_length(df, metacore = df_meta)) + } +) + +## Test 5: xportr_order: using the deprecated metacore argument gives an error ---- +test_that( + "deprecation Test 5: xportr_order: using the deprecated metacore argument gives an error", + { + local_options(lifecycle_verbosity = "quiet") + + 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) + + expect_error(xportr_order(df, metacore = df_meta, domain = "DOMAIN")) + } +) + +## Test 6: xportr_type: using the deprecated metacore argument gives an error ---- +test_that( + "deprecation Test 6: xportr_type: using the deprecated metacore argument gives an error", + { + local_options(lifecycle_verbosity = "quiet") + df <- data.frame( + Subj = as.character(c(123, 456, 789, "", NA, NA_integer_)), + Different = c("a", "b", "c", "", NA, NA_character_), + Val = c("1", "2", "3", "", NA, NA_character_), + Param = c("param1", "param2", "param3", "", NA, NA_character_) + ) + df_meta <- data.frame( + dataset = "df", + variable = c("Subj", "Param", "Val", "NotUsed"), + type = c("numeric", "character", "numeric", "character"), + format = NA + ) + + expect_error(xportr_type(df, metacore = df_meta)) + } +) diff --git a/tests/testthat/test-depreciation.R b/tests/testthat/test-depreciation.R deleted file mode 100644 index d1eb0cd2..00000000 --- a/tests/testthat/test-depreciation.R +++ /dev/null @@ -1,72 +0,0 @@ -test_that("xportr_df_label: deprecated metacore gives an error", { - local_options(lifecycle_verbosity = "quiet") - df <- data.frame(x = "a", y = "b") - df_meta <- data.frame(dataset = "df", label = "Label") - - expect_error(xportr_df_label(df, metacore = df_meta)) -}) - -test_that("xportr_format: deprecated metacore gives an error", { - local_options(lifecycle_verbosity = "quiet") - df <- data.frame(x = 1, y = 2) - df_meta <- data.frame( - dataset = "df", - variable = "x", - format = "date9." - ) - - expect_error(xportr_format(df, metacore = df_meta)) -}) - -test_that("xportr_label: using the deprecated metacore argument gives an error", { - local_options(lifecycle_verbosity = "quiet") - - df <- data.frame(x = "a", y = "b") - df_meta <- data.frame(dataset = "df", variable = "x", label = "foo") - - expect_error(xportr_label(df, metacore = df_meta)) -}) - -test_that("xportr_length: using the deprecated metacore argument gives an error", { - local_options(lifecycle_verbosity = "quiet") - df <- data.frame(x = "a", y = "b") - df_meta <- data.frame( - dataset = "df", - variable = c("x", "y"), - type = c("text", "text"), - length = c(1, 2) - ) - - expect_error(xportr_length(df, metacore = df_meta)) -}) - -test_that("xportr_order: using the deprecated metacore argument gives an error", { - local_options(lifecycle_verbosity = "quiet") - - 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 - ) - - expect_error(xportr_order(df, metacore = df_meta, domain = "DOMAIN")) -}) - -test_that("xportr_type: using the deprecated metacore argument gives an error", { - local_options(lifecycle_verbosity = "quiet") - df <- data.frame( - Subj = as.character(c(123, 456, 789, "", NA, NA_integer_)), - Different = c("a", "b", "c", "", NA, NA_character_), - Val = c("1", "2", "3", "", NA, NA_character_), - Param = c("param1", "param2", "param3", "", NA, NA_character_) - ) - df_meta <- data.frame( - dataset = "df", - variable = c("Subj", "Param", "Val", "NotUsed"), - type = c("numeric", "character", "numeric", "character"), - format = NA - ) - - expect_error(xportr_type(df, metacore = df_meta)) -}) diff --git a/tests/testthat/test-df_label.R b/tests/testthat/test-df_label.R index 1a0cfdd8..ebf3cbac 100644 --- a/tests/testthat/test-df_label.R +++ b/tests/testthat/test-df_label.R @@ -1,4 +1,5 @@ -test_that("xportr_df_label: error when metadata is not set", { +## Test 1: xportr_df_label: error when metadata is not set ---- +test_that("df_label Test 1: xportr_df_label: error when metadata is not set", { adsl <- minimal_table() expect_error( diff --git a/tests/testthat/test-format.R b/tests/testthat/test-format.R index 7769cd10..0fc578a0 100644 --- a/tests/testthat/test-format.R +++ b/tests/testthat/test-format.R @@ -1,4 +1,5 @@ -test_that("xportr_format: error when metadata is not set", { +## Test 1: xportr_format: error when metadata is not set ---- +test_that("format Test 1: xportr_format: error when metadata is not set", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) @@ -10,7 +11,8 @@ test_that("xportr_format: error when metadata is not set", { ) }) -test_that("xportr_format: Gets warning when metadata has multiple rows with same variable", { +## Test 2: xportr_format: Gets warning when metadata has multiple rows with same variable ---- +test_that("format Test 2: xportr_format: Gets warning when metadata has multiple rows with same variable", { # This test uses the (2) functions below to reduce code duplication # All `expect_*` are being called inside the functions # @@ -20,7 +22,8 @@ test_that("xportr_format: Gets warning when metadata has multiple rows with same multiple_vars_in_spec_helper2(xportr_format) }) -test_that("xportr_format: Works as expected with only one domain in metadata", { +## Test 3: xportr_format: Works as expected with only one domain in metadata ---- +test_that("format Test 3: xportr_format: Works as expected with only one domain in metadata", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) @@ -35,7 +38,8 @@ test_that("xportr_format: Works as expected with only one domain in metadata", { expect_silent(xportr_format(adsl, metadata)) }) -test_that("xportr_format: Variable ending in DT should produce a warning if no format", { +## Test 4: xportr_format: Variable ending in DT should produce a warning if no format ---- +test_that("format Test 4: xportr_format: Variable ending in DT should produce a warning if no format", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) @@ -54,7 +58,8 @@ test_that("xportr_format: Variable ending in DT should produce a warning if no f ) }) -test_that("xportr_format: Variable ending in TM should produce an error if no format", { +## Test 5: xportr_format: Variable ending in TM should produce an error if no format ---- +test_that("format Test 5: xportr_format: Variable ending in TM should produce an error if no format", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHTM = c(1, 1, 2) @@ -73,7 +78,8 @@ test_that("xportr_format: Variable ending in TM should produce an error if no fo ) }) -test_that("xportr_format: Variable ending in DTM should produce a warning if no format", { +## Test 6: xportr_format: Variable ending in DTM should produce a warning if no format ---- +test_that("format Test 6: xportr_format: Variable ending in DTM should produce a warning if no format", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDTM = c(1, 1, 2) @@ -114,7 +120,8 @@ test_that( } ) -test_that("xportr_format: If a variable is character then a warning should be produced if format is > 32 in length", { +## Test 7: xportr_format: If a variable is character then a warning should be produced if format is > 32 in length ---- +test_that("format Test 7: xportr_format: If a variable is character then a warning should be produced if format is > 32 in length", { adsl <- data.frame( USUBJID = c("1001", "1002", "1003"), BRTHDT = c(1, 1, 2) @@ -141,7 +148,8 @@ test_that("xportr_format: If a variable is character then a warning should be pr ) }) -test_that("xportr_format: If a variable is numeric then an error should be produced if a format starts with `$`", { +## Test 8: xportr_format: If a variable is numeric then an error should be produced if a format starts with `$` ---- +test_that("format Test 8: xportr_format: If a variable is numeric then an error should be produced if a format starts with `$`", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) @@ -160,7 +168,8 @@ test_that("xportr_format: If a variable is numeric then an error should be produ ) }) -test_that("xportr_format: If a variable is numeric then a warning should be produced if format is > 32 in length", { +## Test 9: xportr_format: If a variable is numeric then a warning should be produced if format is > 32 in length ---- +test_that("format Test 9: xportr_format: If a variable is numeric then a warning should be produced if format is > 32 in length", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) diff --git a/tests/testthat/test-label.R b/tests/testthat/test-label.R index bb0a9e3b..88b52a3f 100644 --- a/tests/testthat/test-label.R +++ b/tests/testthat/test-label.R @@ -1,4 +1,5 @@ -test_that("xportr_label: error when metadata is not set", { +## Test 1: xportr_label: error when metadata is not set ---- +test_that("label Test 1: xportr_label: error when metadata is not set", { df <- data.frame( Subj = as.character(123, 456, 789), Different = c("a", "b", "c"), @@ -6,34 +7,36 @@ test_that("xportr_label: error when metadata is not set", { Param = c("param1", "param2", "param3") ) - expect_error( - xportr_label(df), - regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" - ) + expect_error(xportr_label(df), + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'") }) -test_that("xportr_label: Gets warning when metadata has multiple rows with same variable", { - # This test uses the (2) functions below to reduce code duplication - # All `expect_*` are being called inside the functions - # - # Checks that message appears when xportr.domain_name is invalid - multiple_vars_in_spec_helper(xportr_label) - # Checks that message doesn't appear when xportr.domain_name is valid - multiple_vars_in_spec_helper2(xportr_label) -}) +## Test 2: xportr_label: Gets warning when metadata has multiple rows with same variable ---- +test_that( + "label Test 2: xportr_label: Gets warning when metadata has multiple rows with same variable", + { + # This test uses the (2) functions below to reduce code duplication + # All `expect_*` are being called inside the functions + # + # Checks that message appears when xportr.domain_name is invalid + multiple_vars_in_spec_helper(xportr_label) + # Checks that message doesn't appear when xportr.domain_name is valid + multiple_vars_in_spec_helper2(xportr_label) + } +) -test_that("xportr_label: Works as expected with only one domain in metadata", { - adsl <- data.frame( - USUBJID = c(1001, 1002, 1003), - BRTHDT = c(1, 1, 2) - ) +## Test 3: xportr_label: Works as expected with only one domain in metadata ---- +test_that("label Test 3: xportr_label: Works as expected with only one domain in metadata", + { + adsl <- data.frame(USUBJID = c(1001, 1002, 1003), + BRTHDT = c(1, 1, 2)) - metadata <- data.frame( - dataset = c("adsl", "adsl"), - variable = c("USUBJID", "BRTHDT"), - label = c("Hello", "Hello2") - ) + metadata <- data.frame( + dataset = c("adsl", "adsl"), + variable = c("USUBJID", "BRTHDT"), + label = c("Hello", "Hello2") + ) - expect_silent(xportr_label(adsl, metadata)) -}) + expect_silent(xportr_label(adsl, metadata)) + }) diff --git a/tests/testthat/test-length.R b/tests/testthat/test-length.R index 12fce410..b21f5e2b 100644 --- a/tests/testthat/test-length.R +++ b/tests/testthat/test-length.R @@ -5,141 +5,156 @@ #' * Result of call will create SAS default length attribute (`width` for each #' variable) -test_that("xportr_length: Accepts valid domain names in metadata object", { - adsl <- minimal_table(30) - metadata <- minimal_metadata(dataset = TRUE, length = TRUE, var_names = colnames(adsl)) - - # Setup temporary options with active verbose - local_options(xportr.length_verbose = "message") - - # Test minimal call with valid data and without domain - adsl %>% - xportr_metadata(domain = "adsl") %>% - xportr_length(metadata) %>% - expect_silent() %>% - expect_attr_width(metadata$length) - - # Test minimal call with valid data with a valid domain - xportr_length(adsl, metadata, domain = "adsl") %>% - expect_silent() %>% - expect_attr_width(metadata$length) %>% - NROW() %>% - expect_equal(30) - - # Test minimal call without datasets - metadata_without_dataset <- metadata %>% select(-"dataset") - - xportr_length(adsl, metadata_without_dataset, domain = "adsl") %>% - expect_silent() %>% - expect_attr_width(metadata_without_dataset$length) %>% - NROW() %>% - expect_equal(30) - - # Test minimal call without datasets and ignores domain - xportr_length(adsl, metadata_without_dataset, domain = "something_else") %>% - expect_silent() %>% - expect_attr_width(metadata_without_dataset$length) %>% - NROW() %>% - expect_equal(30) -}) - -test_that("xportr_length: CDISC data frame is being piped after another xportr function", { - adsl <- minimal_table(30) - metadata <- minimal_metadata( - dataset = TRUE, length = TRUE, type = TRUE, format = TRUE, var_names = colnames(adsl) - ) - - # Setup temporary options with active verbose - local_options(xportr.length_verbose = "message") - - adsl %>% - xportr_type(metadata, domain = "adsl", verbose = "message") %>% - xportr_length(metadata) %>% - expect_silent() %>% - expect_attr_width(metadata$length) %>% - attr("_xportr.df_arg_") %>% - expect_equal("adsl") -}) - -test_that("xportr_length: Impute character lengths based on class", { - adsl <- minimal_table(30, cols = c("x", "b")) - metadata <- minimal_metadata( - dataset = TRUE, length = TRUE, var_names = colnames(adsl) - ) %>% - mutate(length = length - 1) - - # Setup temporary options with `verbose = "none"` - local_options(xportr.length_verbose = "none") - # Define controlled `character_types` for this test - local_options(xportr.character_types = c("character", "date")) - - # Remove empty lines in cli theme - local_cli_theme() - - # Test length imputation of character and numeric (not valid character type) - result <- adsl %>% - xportr_length(metadata, domain = "adsl") %>% - expect_silent() - - expect_attr_width(result, c(7, 199)) - - # Test length imputation of two valid character types (both should have - # `width = 200``) - adsl <- adsl %>% - mutate( - new_date = as.Date(.data$x, origin = "1970-01-01"), - new_char = as.character(.data$b), - new_num = as.numeric(.data$x) +## Test 1: xportr_length: Accepts valid domain names in metadata object ---- +test_that("length Test 1: xportr_length: Accepts valid domain names in metadata object", + { + adsl <- minimal_table(30) + metadata <- + minimal_metadata(dataset = TRUE, + length = TRUE, + var_names = colnames(adsl)) + + # Setup temporary options with active verbose + local_options(xportr.length_verbose = "message") + + # Test minimal call with valid data and without domain + adsl %>% + xportr_metadata(domain = "adsl") %>% + xportr_length(metadata) %>% + expect_silent() %>% + expect_attr_width(metadata$length) + + # Test minimal call with valid data with a valid domain + xportr_length(adsl, metadata, domain = "adsl") %>% + expect_silent() %>% + expect_attr_width(metadata$length) %>% + NROW() %>% + expect_equal(30) + + # Test minimal call without datasets + metadata_without_dataset <- metadata %>% select(-"dataset") + + xportr_length(adsl, metadata_without_dataset, domain = "adsl") %>% + expect_silent() %>% + expect_attr_width(metadata_without_dataset$length) %>% + NROW() %>% + expect_equal(30) + + # Test minimal call without datasets and ignores domain + xportr_length(adsl, metadata_without_dataset, domain = "something_else") %>% + expect_silent() %>% + expect_attr_width(metadata_without_dataset$length) %>% + NROW() %>% + expect_equal(30) + }) + +## Test 2: xportr_length: CDISC data frame is being piped after another xportr function ---- +test_that( + "length Test 2: xportr_length: CDISC data frame is being piped after another xportr function", + { + adsl <- minimal_table(30) + metadata <- minimal_metadata( + dataset = TRUE, + length = TRUE, + type = TRUE, + format = TRUE, + var_names = colnames(adsl) ) - adsl %>% - xportr_length(metadata, domain = "adsl") %>% - expect_message("Variable lengths missing from metadata") %>% - expect_message("lengths resolved") %>% - expect_attr_width(c(7, 199, 200, 200, 8)) -}) - -test_that("xportr_length: Throws message when variables not present in metadata", { - adsl <- minimal_table(30, cols = c("x", "y")) - metadata <- minimal_metadata(dataset = TRUE, length = TRUE, var_names = c("x")) - - # Setup temporary options with `verbose = "message"` - local_options(xportr.length_verbose = "message") - # Remove empty lines in cli theme - local_cli_theme() - - # Test that message is given which indicates that variable is not present - xportr_length(adsl, metadata, domain = "adsl") %>% - expect_message("Variable lengths missing from metadata") %>% - expect_message("lengths resolved") %>% - expect_message(regexp = "Problem with `y`") -}) + # Setup temporary options with active verbose + local_options(xportr.length_verbose = "message") + + adsl %>% + xportr_type(metadata, domain = "adsl", verbose = "message") %>% + xportr_length(metadata) %>% + expect_silent() %>% + expect_attr_width(metadata$length) %>% + attr("_xportr.df_arg_") %>% + expect_equal("adsl") + } +) -test_that("xportr_length: Metacore instance can be used", { +## Test 3: xportr_length: Impute character lengths based on class ---- +test_that("length Test 3: xportr_length: Impute character lengths based on class", + { + adsl <- minimal_table(30, cols = c("x", "b")) + metadata <- minimal_metadata(dataset = TRUE, + length = TRUE, + var_names = colnames(adsl)) %>% + mutate(length = length - 1) + + # Setup temporary options with `verbose = "none"` + local_options(xportr.length_verbose = "none") + # Define controlled `character_types` for this test + local_options(xportr.character_types = c("character", "date")) + + # Remove empty lines in cli theme + local_cli_theme() + + # Test length imputation of character and numeric (not valid character type) + result <- adsl %>% + xportr_length(metadata, domain = "adsl") %>% + expect_silent() + + expect_attr_width(result, c(7, 199)) + + # Test length imputation of two valid character types (both should have + # `width = 200``) + adsl <- adsl %>% + mutate( + new_date = as.Date(.data$x, origin = "1970-01-01"), + new_char = as.character(.data$b), + new_num = as.numeric(.data$x) + ) + + adsl %>% + xportr_length(metadata, domain = "adsl") %>% + expect_message("Variable lengths missing from metadata") %>% + expect_message("lengths resolved") %>% + expect_attr_width(c(7, 199, 200, 200, 8)) + }) + +## Test 4: xportr_length: Throws message when variables not present in metadata ---- +test_that("length Test 4: xportr_length: Throws message when variables not present in metadata", + { + adsl <- minimal_table(30, cols = c("x", "y")) + metadata <- + minimal_metadata(dataset = TRUE, + length = TRUE, + var_names = c("x")) + + # Setup temporary options with `verbose = "message"` + local_options(xportr.length_verbose = "message") + # Remove empty lines in cli theme + local_cli_theme() + + # Test that message is given which indicates that variable is not present + xportr_length(adsl, metadata, domain = "adsl") %>% + expect_message("Variable lengths missing from metadata") %>% + expect_message("lengths resolved") %>% + expect_message(regexp = "Problem with `y`") + }) + +## Test 5: xportr_length: Metacore instance can be used ---- +test_that("length Test 5: xportr_length: Metacore instance can be used", { skip_if_not_installed("metacore") adsl <- minimal_table(30, cols = c("x", "b")) # Build a minimal metacore object - metadata <- suppressMessages( - suppressWarnings( - metacore::metacore( - ds_spec = dplyr::tibble( - dataset = "ADSL" - ), - ds_vars = dplyr::tibble( - dataset = "ADSL", - variable = colnames(adsl) - ), - var_spec = minimal_metadata( - length = TRUE, - type = TRUE, - label = TRUE, - format = TRUE, - order = TRUE - ) + metadata <- suppressMessages(suppressWarnings( + metacore::metacore( + ds_spec = dplyr::tibble(dataset = "ADSL"), + ds_vars = dplyr::tibble(dataset = "ADSL", + variable = colnames(adsl)), + var_spec = minimal_metadata( + length = TRUE, + type = TRUE, + label = TRUE, + format = TRUE, + order = TRUE ) ) - ) + )) # Test metacore parameter with `metacore` class instead of data.frame xportr_length(adsl, metadata, domain = "adsl", verbose = "message") %>% @@ -149,38 +164,42 @@ test_that("xportr_length: Metacore instance can be used", { expect_attr_width(metadata$length) }) -test_that("xportr_length: Domain not in character format", { +## Test 6: xportr_length: Domain not in character format ---- +test_that("length Test 6: xportr_length: Domain not in character format", { skip_if_not_installed("readxl") require(haven, quietly = TRUE) require(readxl, quietly = TRUE) - ADAE <- read_sas(system.file("extdata", "adae.sas7bdat", package = "xportr")) - met <- read_excel(system.file("specs", "ADaM_spec.xlsx", package = "xportr"), 3) + ADAE <- + read_sas(system.file("extdata", "adae.sas7bdat", package = "xportr")) + met <- + read_excel(system.file("specs", "ADaM_spec.xlsx", package = "xportr"), 3) - expect_error( - xportr_length(ADAE, met, domain = ADAE, verbose = "none") - ) + expect_error(xportr_length(ADAE, met, domain = ADAE, verbose = "none")) }) -test_that("xportr_length: error when metadata is not set", { +## Test 7: xportr_length: error when metadata is not set ---- +test_that("length Test 7: xportr_length: error when metadata is not set", { adsl <- minimal_table(30) - expect_error( - xportr_length(adsl), - regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" - ) + expect_error(xportr_length(adsl), + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'") }) -test_that("xportr_length: Gets warning when metadata has multiple rows with same variable", { - # This test uses the (2) functions below to reduce code duplication - # All `expect_*` are being called inside the functions - # - # Checks that message appears when xportr.domain_name is invalid - multiple_vars_in_spec_helper(xportr_length) - # Checks that message doesn't appear when xportr.domain_name is valid - multiple_vars_in_spec_helper2(xportr_length) -}) +## Test 8: xportr_length: Gets warning when metadata has multiple rows with same variable ---- +test_that( + "length Test 8: xportr_length: Gets warning when metadata has multiple rows with same variable", + { + # This test uses the (2) functions below to reduce code duplication + # All `expect_*` are being called inside the functions + # + # Checks that message appears when xportr.domain_name is invalid + multiple_vars_in_spec_helper(xportr_length) + # Checks that message doesn't appear when xportr.domain_name is valid + multiple_vars_in_spec_helper2(xportr_length) + } +) meta_example <- data.frame( dataset = "df", @@ -188,38 +207,43 @@ meta_example <- data.frame( length = c(10, 8) ) -df <- data.frame( - USUBJID = c("1", "12", "123"), - WEIGHT = c(85, 45, 121) +df <- data.frame(USUBJID = c("1", "12", "123"), + WEIGHT = c(85, 45, 121)) + +## Test 9: xportr_length: length assigned as expected from metadata or data ---- +test_that("length Test 9: xportr_length: length assigned as expected from metadata or data", + { + result <- df %>% + xportr_length(meta_example, domain = "df", length_source = "metadata") %>% + expect_attr_width(c(10, 8)) + suppressMessages( + result <- df %>% + xportr_length(meta_example, domain = "df", length_source = "data") %>% + expect_attr_width(c(3, 8)) + ) + }) + +## Test 10: xportr_length: Gets message when length in metadata longer than data length ---- +test_that( + "length Test 10: xportr_length: Gets message when length in metadata longer than data length", + { + result <- df %>% + xportr_length(meta_example, domain = "df", length_source = "data") %>% + expect_message() + } ) -test_that("xportr_length: length assigned as expected from metadata or data", { - result <- df %>% - xportr_length(meta_example, domain = "df", length_source = "metadata") %>% - expect_attr_width(c(10, 8)) +## Test 11: xportr_length: Works as expected with only one domain in metadata ---- +test_that("length Test 11: xportr_length: Works as expected with only one domain in metadata", + { + adsl <- data.frame(USUBJID = c(1001, 1002, 1003), + BRTHDT = c(1, 1, 2)) - result <- df %>% - xportr_length(meta_example, domain = "df", length_source = "data") %>% - expect_attr_width(c(3, 8)) -}) + metadata <- data.frame( + dataset = c("adsl", "adsl"), + variable = c("USUBJID", "BRTHDT"), + length = c(1, 1) + ) -test_that("xportr_length: Gets message when length in metadata longer than data length", { - result <- df %>% - xportr_length(meta_example, domain = "df", length_source = "data") %>% - expect_message() -}) - -test_that("xportr_length: Works as expected with only one domain in metadata", { - adsl <- data.frame( - USUBJID = c(1001, 1002, 1003), - BRTHDT = c(1, 1, 2) - ) - - metadata <- data.frame( - dataset = c("adsl", "adsl"), - variable = c("USUBJID", "BRTHDT"), - length = c(1, 1) - ) - - expect_silent(xportr_length(adsl, metadata)) -}) + expect_silent(xportr_length(adsl, metadata)) + }) diff --git a/tests/testthat/test-messages.R b/tests/testthat/test-messages.R index 1da3e004..b8b14e79 100644 --- a/tests/testthat/test-messages.R +++ b/tests/testthat/test-messages.R @@ -1,71 +1,77 @@ #' Test `R/messages.R` functions -test_that("xportr_logger: Type parameter will create correct message type", { - xportr_logger("A message", type = "none") %>% - expect_silent() +## Test 1: xportr_logger: Type parameter will create correct message type ---- +test_that("messages Test 1: xportr_logger: Type parameter will create correct message type", + { + xportr_logger("A message", type = "none") %>% + expect_silent() - xportr_logger("A message", type = "message") %>% - expect_message("A message") + xportr_logger("A message", type = "message") %>% + expect_message("A message") - xportr_logger("A message", type = "warn") %>% - expect_warning("A message") + xportr_logger("A message", type = "warn") %>% + expect_warning("A message") - xportr_logger("A message", type = "stop") %>% - expect_error("A message") + xportr_logger("A message", type = "stop") %>% + expect_error("A message") - # Supports additional parameters to rlang::stop - xportr_logger("A message", type = "stop", footer = "A footer") %>% - expect_error("A message", class = "rlang_error") -}) + # Supports additional parameters to rlang::stop + xportr_logger("A message", type = "stop", footer = "A footer") %>% + expect_error("A message", class = "rlang_error") + }) -test_that("length_log: Missing lengths messages are shown", { - # Remove empty lines in cli theme - local_cli_theme() +## Test 2: length_log: Missing lengths messages are shown ---- +test_that("messages Test 2: length_log: Missing lengths messages are shown", + { + # Remove empty lines in cli theme + local_cli_theme() - length_log(c("var1", "var2", "var3"), c("var4"), "message") %>% - expect_message("Variable lengths missing from metadata.") %>% - expect_message("lengths resolved `var1`.*`var2`.*`var3`.*`var4`") %>% - expect_message("Problem with `var1`.*`var2`.*`var3`") -}) + length_log(c("var1", "var2", "var3"), c("var4"), "message") %>% + expect_message("Variable lengths missing from metadata.") %>% + expect_message("lengths resolved `var1`.*`var2`.*`var3`.*`var4`") %>% + expect_message("Problem with `var1`.*`var2`.*`var3`") + }) -test_that("length_log: Missing variables messages are shown", { - # Remove empty lines in cli theme - local_cli_theme() +## Test 3: length_log: Missing variables messages are shown ---- +test_that("messages Test 3: length_log: Missing variables messages are shown", + { + # Remove empty lines in cli theme + local_cli_theme() - label_log(c("var1", "var2", "var3"), "message") %>% - # cli messages - expect_message("Variable labels missing from metadata.") %>% - expect_message("labels skipped") %>% - # xportr_logger messages - expect_message("Problem with `var1`.*`var2`.*`var3`") -}) + label_log(c("var1", "var2", "var3"), "message") %>% + # cli messages + expect_message("Variable labels missing from metadata.") %>% + expect_message("labels skipped") %>% + # xportr_logger messages + expect_message("Problem with `var1`.*`var2`.*`var3`") + }) -test_that("var_names_log: Renamed variables messages are shown", { - # Remove empty lines in cli theme - local_cli_theme() +## Test 4: var_names_log: Renamed variables messages are shown ---- +test_that("messages Test 4: var_names_log: Renamed variables messages are shown", + { + # Remove empty lines in cli theme + local_cli_theme() - tidy_names_df <- data.frame( - original_varname = c("var1", "var2", "var3", "var4", "VAR5", "VAR6"), - renamed_var = c("VAR1", "VAR2", "VAR3", "VAR4", "VAR5", "VAR6"), - col_pos = seq(1, 6), - renamed_msg = glue("renamed message {seq(1, 6)}"), - renamed_n = 0 - ) + tidy_names_df <- data.frame( + original_varname = c("var1", "var2", "var3", "var4", "VAR5", "VAR6"), + renamed_var = c("VAR1", "VAR2", "VAR3", "VAR4", "VAR5", "VAR6"), + col_pos = seq(1, 6), + renamed_msg = glue("renamed message {seq(1, 6)}"), + renamed_n = 0 + ) - tidy_names_df %>% - mutate( - renamed_n = c( - 2, - sample(c(0, 1, 2), size = NROW(.data$renamed_n) - 1, replace = TRUE) - ) - ) %>% - 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 '.*'") %>% - expect_message("Var . : '.*' was renamed to '.*'") %>% - expect_message("Duplicate renamed term\\(s\\) were created") -}) + tidy_names_df %>% + mutate(renamed_n = c(2, + sample( + c(0, 1, 2), + size = NROW(.data$renamed_n) - 1, + replace = TRUE + ))) %>% + 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 '.*'") %>% + expect_message("Var . : '.*' was renamed to '.*'") %>% + expect_message("Duplicate renamed term\\(s\\) were created") + }) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index f1cf9228..b09e9ab4 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -10,7 +10,8 @@ extract_var_label <- function(.x) { vapply(.x, function(.x) attr(.x, "label"), character(1), USE.NAMES = FALSE) } -test_that("xportr_label: Correctly applies label from data.frame spec", { +## Test 1: xportr_label: Correctly applies label from data.frame spec ---- +test_that("metadata Test 1: xportr_label: Correctly applies label from data.frame spec", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "df", variable = c("x", "y"), label = c("foo", "bar")) @@ -32,7 +33,8 @@ test_that("xportr_label: Correctly applies label from data.frame spec", { ) }) -test_that("xportr_label: Correctly applies label when data is piped", { +## Test 2: xportr_label: Correctly applies label when data is piped ---- +test_that("metadata Test 2: xportr_label: Correctly applies label when data is piped", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "df", variable = c("x", "y"), label = c("foo", "bar")) @@ -53,7 +55,8 @@ test_that("xportr_label: Correctly applies label when data is piped", { ) }) -test_that("xportr_label: Correctly applies label for custom domain", { +## Test 3: xportr_label: Correctly applies label for custom domain ---- +test_that("metadata Test 3: xportr_label: Correctly applies label for custom domain", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = rep("DOMAIN", 2), variable = c("x", "y"), label = c("foo", "bar")) @@ -74,7 +77,8 @@ test_that("xportr_label: Correctly applies label for custom domain", { ) }) -test_that("xportr_label: Correctly applies label from metacore spec", { +## Test 4: xportr_label: Correctly applies label from metacore spec ---- +test_that("metadata Test 4: xportr_label: Correctly applies label from metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = "a", y = "b", variable = "value") @@ -111,7 +115,8 @@ test_that("xportr_label: Correctly applies label from metacore spec", { ) }) -test_that("xportr_label: Expect error if any variable does not exist in metadata", { +## Test 5: xportr_label: Expect error if any variable does not exist in metadata ---- +test_that("metadata Test 5: xportr_label: Expect error if any variable does not exist in metadata", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -124,7 +129,8 @@ test_that("xportr_label: Expect error if any variable does not exist in metadata expect_error() }) -test_that("xportr_label: Expect error if label exceeds 40 characters", { +## Test 6: xportr_label: Expect error if label exceeds 40 characters ---- +test_that("metadata Test 6: xportr_label: Expect error if label exceeds 40 characters", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -136,7 +142,8 @@ test_that("xportr_label: Expect error if label exceeds 40 characters", { expect_warning("variable label must be 40 characters or less") }) -test_that("xportr_label: Expect error if domain is not a character", { +## Test 7: xportr_label: Expect error if domain is not a character ---- +test_that("metadata Test 7: xportr_label: Expect error if domain is not a character", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -154,7 +161,8 @@ test_that("xportr_label: Expect error if domain is not a character", { ) }) -test_that("xportr_df_label: Correctly applies label from data.frame spec", { +## Test 8: xportr_df_label: Correctly applies label from data.frame spec ---- +test_that("metadata Test 8: xportr_df_label: Correctly applies label from data.frame spec", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "df", label = "Label") @@ -173,7 +181,8 @@ test_that("xportr_df_label: Correctly applies label from data.frame spec", { ) }) -test_that("xportr_df_label: Correctly applies label when data is piped", { +## Test 9: xportr_df_label: Correctly applies label when data is piped ---- +test_that("metadata Test 9: 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") @@ -192,7 +201,8 @@ test_that("xportr_df_label: Correctly applies label when data is piped", { ) }) -test_that("xportr_df_label: Correctly applies label for custom domain", { +## Test 10: xportr_df_label: Correctly applies label for custom domain ---- +test_that("metadata Test 10: xportr_df_label: Correctly applies label for custom domain", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "DOMAIN", label = "Label") @@ -208,7 +218,8 @@ test_that("xportr_df_label: Correctly applies label for custom domain", { ) }) -test_that("xportr_df_label: Correctly applies label from metacore spec", { +## Test 11: xportr_df_label: Correctly applies label from metacore spec ---- +test_that("metadata Test 11: xportr_df_label: Correctly applies label from metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = "a", y = "b") @@ -236,7 +247,8 @@ test_that("xportr_df_label: Correctly applies label from metacore spec", { ) }) -test_that("xportr_df_label: Expect error if label exceeds 40 characters", { +## Test 12: xportr_df_label: Expect error if label exceeds 40 characters ---- +test_that("metadata Test 12: xportr_df_label: Expect error if label exceeds 40 characters", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -249,7 +261,8 @@ test_that("xportr_df_label: Expect error if label exceeds 40 characters", { ) }) -test_that("xportr_df_label: Expect error if domain is not a character", { +## Test 13: xportr_df_label: Expect error if domain is not a character ---- +test_that("metadata Test 13: xportr_df_label: Expect error if domain is not a character", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -266,7 +279,8 @@ test_that("xportr_df_label: Expect error if domain is not a character", { ) }) -test_that("xportr_format: Set formats as expected", { +## Test 14: xportr_format: Set formats as expected ---- +test_that("metadata Test 14: xportr_format: Set formats as expected", { df <- data.frame(x = 1, y = 2) df_meta <- data.frame( dataset = "df", @@ -286,7 +300,8 @@ test_that("xportr_format: Set formats as expected", { )) }) -test_that("xportr_format: Set formats as expected when data is piped", { +## Test 15: xportr_format: Set formats as expected when data is piped ---- +test_that("metadata Test 15: xportr_format: Set formats as expected when data is piped", { df <- data.frame(x = 1, y = 2) df_meta <- data.frame( dataset = "df", @@ -306,7 +321,8 @@ test_that("xportr_format: Set formats as expected when data is piped", { )) }) -test_that("xportr_format: Set formats as expected for metacore spec", { +## Test 16: xportr_format: Set formats as expected for metacore spec ---- +test_that("metadata Test 16: xportr_format: Set formats as expected for metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = 1, y = 2) metacore_meta <- suppressMessages(suppressWarnings( @@ -334,7 +350,8 @@ test_that("xportr_format: Set formats as expected for metacore spec", { )) }) -test_that("xportr_format: Set formats as expected for custom domain", { +## Test 17: xportr_format: Set formats as expected for custom domain ---- +test_that("metadata Test 17: xportr_format: Set formats as expected for custom domain", { df <- data.frame(x = 1, y = 2) df_meta <- data.frame( dataset = "DOMAIN", @@ -354,7 +371,8 @@ test_that("xportr_format: Set formats as expected for custom domain", { )) }) -test_that("xportr_format: Handle NA values without raising an error", { +## Test 18: xportr_format: Handle NA values without raising an error ---- +test_that("metadata Test 18: xportr_format: Handle NA values without raising an error", { df <- data.frame(x = 1, y = 2, z = 3, a = 4) df_meta <- data.frame( dataset = rep("df", 4), @@ -376,7 +394,8 @@ test_that("xportr_format: Handle NA values without raising an error", { )) }) -test_that("xportr_format: Expect error if domain is not a character", { +## Test 19: xportr_format: Expect error if domain is not a character ---- +test_that("metadata Test 19: xportr_format: Expect error if domain is not a character", { df <- data.frame(x = 1, y = 2, z = 3, a = 4) df_meta <- data.frame( dataset = "df", @@ -394,7 +413,8 @@ test_that("xportr_format: Expect error if domain is not a character", { ) }) -test_that("xportr_length: Check if width attribute is set properly", { +## Test 20: xportr_length: Check if width attribute is set properly ---- +test_that("metadata Test 20: xportr_length: Check if width attribute is set properly", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -415,7 +435,8 @@ test_that("xportr_length: Check if width attribute is set properly", { )) }) -test_that("xportr_length: Check if width attribute is set properly when data is piped", { +## Test 21: xportr_length: Check if width attribute is set properly when data is piped ---- +test_that("metadata Test 21: xportr_length: Check if width attribute is set properly when data is piped", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -436,7 +457,8 @@ test_that("xportr_length: Check if width attribute is set properly when data is )) }) -test_that("xportr_length: Check if width attribute is set properly for metacore spec", { +## Test 22: xportr_length: Check if width attribute is set properly for metacore spec ---- +test_that("metadata Test 22: xportr_length: Check if width attribute is set properly for metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = "a", y = "b") metacore_meta <- suppressMessages(suppressWarnings( @@ -464,7 +486,8 @@ test_that("xportr_length: Check if width attribute is set properly for metacore )) }) -test_that("xportr_length: Check if width attribute is set properly when custom domain is passed", { +## Test 23: xportr_length: Check if width attribute is set properly when custom domain is passed ---- +test_that("metadata Test 23: xportr_length: Check if width attribute is set properly when custom domain is passed", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = rep("DOMAIN", 2), @@ -485,7 +508,8 @@ test_that("xportr_length: Check if width attribute is set properly when custom d )) }) -test_that("xportr_length: Expect error when a variable is not present in metadata", { +## Test 24: xportr_length: Expect error when a variable is not present in metadata ---- +test_that("metadata Test 24: xportr_length: Expect error when a variable is not present in metadata", { df <- data.frame(x = "a", y = "b", z = "c") df_meta <- data.frame( dataset = "df", @@ -500,7 +524,8 @@ test_that("xportr_length: Expect error when a variable is not present in metadat expect_error("doesn't exist") }) -test_that("xportr_length: Check if length gets imputed when a new variable is passed", { +## Test 25: xportr_length: Check if length gets imputed when a new variable is passed ---- +test_that("metadata Test 25: xportr_length: Check if length gets imputed when a new variable is passed", { df <- data.frame(x = "a", y = "b", z = 3) df_meta <- data.frame( dataset = "df", @@ -525,7 +550,8 @@ test_that("xportr_length: Check if length gets imputed when a new variable is pa )) }) -test_that("xportr_length: Expect error if domain is not a character", { +## Test 26: xportr_length: Expect error if domain is not a character ---- +test_that("metadata Test 26: xportr_length: Expect error if domain is not a character", { df <- data.frame(x = "a", y = "b", z = 3) df_meta <- data.frame( dataset = "df", @@ -544,7 +570,8 @@ test_that("xportr_length: Expect error if domain is not a character", { ) }) -test_that("xportr_metadata: Impute character lengths based on class", { +## Test 27: xportr_metadata: Impute character lengths based on class ---- +test_that("metadata Test 27: xportr_metadata: Impute character lengths based on class", { adsl <- minimal_table(30, cols = c("x", "b")) metadata <- minimal_metadata( dataset = TRUE, length = TRUE, var_names = colnames(adsl) @@ -566,7 +593,8 @@ test_that("xportr_metadata: Impute character lengths based on class", { expect_attr_width(c(7, 199, 200, 200, 8)) }) -test_that("xportr_metadata: Throws message when variables not present in metadata", { +## Test 28: xportr_metadata: Throws message when variables not present in metadata ---- +test_that("metadata Test 28: xportr_metadata: Throws message when variables not present in metadata", { adsl <- minimal_table(30, cols = c("x", "y")) metadata <- minimal_metadata(dataset = TRUE, length = TRUE, var_names = c("x")) @@ -578,12 +606,13 @@ test_that("xportr_metadata: Throws message when variables not present in metadat expect_message(regexp = "Problem with `y`") }) -test_that("xportr_metadata: Variable ordering messaging is correct", { - skip_if_not_installed("haven") - skip_if_not_installed("readxl") +## Test 29: xportr_metadata: Variable ordering messaging is correct ---- +test_that("metadata Test 29: xportr_metadata: Variable ordering messaging is correct", { + #skip_if_not_installed("haven") + #skip_if_not_installed("readxl") - require(haven, quietly = TRUE) - require(readxl, quietly = TRUE) + #require(haven, quietly = TRUE) + #require(readxl, quietly = TRUE) df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) df2 <- data.frame(a = "a", z = "z") @@ -607,7 +636,8 @@ test_that("xportr_metadata: Variable ordering messaging is correct", { expect_message("All variables in dataset are ordered") }) -test_that("xportr_type: Variable types are coerced as expected and can raise messages", { +## Test 30: xportr_type: Variable types are coerced as expected and can raise messages ---- +test_that("metadata Test 30: xportr_type: Variable types are coerced as expected and can raise messages", { df <- data.frame( Subj = as.character(c(123, 456, 789, "", NA, NA_integer_)), Different = c("a", "b", "c", "", NA, NA_character_), @@ -637,7 +667,8 @@ test_that("xportr_type: Variable types are coerced as expected and can raise mes # many tests here are more like qualification/domain testing - this section adds # tests for `xportr_metadata()` basic functionality # start -test_that("xportr_metadata: Check metadata interaction with other functions", { +## Test 31: xportr_metadata: Check metadata interaction with other functions ---- +test_that("metadata Test 31: xportr_metadata: Check metadata interaction with other functions", { data("adsl_xportr", envir = environment()) adsl <- adsl_xportr @@ -711,14 +742,16 @@ test_that("xportr_metadata: Check metadata interaction with other functions", { ) }) -test_that("xportr_metadata: must throw error if both metadata and domain are null", { +## Test 32: xportr_metadata: must throw error if both metadata and domain are null ---- +test_that("metadata Test 32: xportr_metadata: must throw error if both metadata and domain are null", { expect_error( xportr_metadata(data.frame(), metadata = NULL, domain = NULL), "Must provide either `metadata` or `domain` argument" ) }) -test_that("xportr_*: Domain is kept in between calls", { +## Test 33: xportr_*: Domain is kept in between calls ---- +test_that("metadata Test 33: xportr_*: Domain is kept in between calls", { # Divert all messages to tempfile, instead of printing them # note: be aware as this should only be used in tests that don't track # messages @@ -758,7 +791,8 @@ test_that("xportr_*: Domain is kept in between calls", { }) # end -test_that("`xportr_metadata()` results match traditional results", { +## Test 34: `xportr_metadata()` results match traditional results ---- +test_that("metadata Test 34: `xportr_metadata()` results match traditional results", { data("var_spec", "dataset_spec", "adsl_xportr", envir = environment()) adsl <- adsl_xportr diff --git a/tests/testthat/test-options.R b/tests/testthat/test-options.R index 39be84b8..3edc0e2b 100644 --- a/tests/testthat/test-options.R +++ b/tests/testthat/test-options.R @@ -1,4 +1,5 @@ -test_that("options are originally set as expected", { +## Test 1: options are originally set as expected ---- +test_that("options Test 1: options are originally set as expected", { op <- options() expect_equal(op$xportr.df_domain_name, "dataset") @@ -12,7 +13,8 @@ test_that("options are originally set as expected", { }) -test_that("xportr_options: options can be fetched using the xportr_options", { +## Test 2: xportr_options: options can be fetched using the xportr_options ---- +test_that("options Test 2: xportr_options: options can be fetched using the xportr_options", { expect_equal(xportr_options(), xportr_options_list) new_domain <- "new domain name" new_label <- "new label name" @@ -25,7 +27,8 @@ test_that("xportr_options: options can be fetched using the xportr_options", { expect_equal(domain_label, list(xportr.df_domain_name = new_domain, xportr.df_label = new_label)) }) -test_that("xportr_options: options can be set using the xportr_options", { +## Test 3: xportr_options: options can be set using the xportr_options ---- +test_that("options Test 3: xportr_options: options can be set using the xportr_options", { op <- options() on.exit(options(op), add = TRUE, after = FALSE) old_name <- "old name" diff --git a/tests/testthat/test-order.R b/tests/testthat/test-order.R index 9f7a08f6..e7688e65 100644 --- a/tests/testthat/test-order.R +++ b/tests/testthat/test-order.R @@ -1,4 +1,5 @@ -test_that("xportr_order: Variable are ordered correctly for data.frame spec", { +## Test 1: xportr_order: Variable are ordered correctly for data.frame spec ---- +test_that("order Test 1: 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", @@ -11,7 +12,8 @@ test_that("xportr_order: Variable are ordered correctly for data.frame spec", { expect_equal(names(ordered_df), df_meta$variable) }) -test_that("xportr_order: Variable are ordered correctly when data is piped", { +## Test 2: xportr_order: Variable are ordered correctly when data is piped ---- +test_that("order Test 2: 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", @@ -29,7 +31,8 @@ test_that("xportr_order: Variable are ordered correctly when data is piped", { expect_equal(names(ordered_df), df_meta$variable) }) -test_that("xportr_order: Variable are ordered correctly for custom domain", { +## Test 3: xportr_order: Variable are ordered correctly for custom domain ---- +test_that("order Test 3: 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", @@ -44,7 +47,8 @@ test_that("xportr_order: Variable are ordered correctly for custom domain", { expect_equal(names(ordered_df), df_meta$variable) }) -test_that("xportr_order: Variable are ordered correctly for metacore spec", { +## Test 4: xportr_order: Variable are ordered correctly for metacore spec ---- +test_that("order Test 4: xportr_order: Variable are ordered correctly for metacore spec", { skip_if_not_installed("metacore") df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) @@ -74,7 +78,8 @@ test_that("xportr_order: Variable are ordered correctly for metacore spec", { expect_equal(names(ordered_df), ordered_columns) }) -test_that("xportr_order: Variable are ordered when custom domain_name is passed", { +## Test 5: xportr_order: Variable are ordered when custom domain_name is passed ---- +test_that("order Test 5: 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", @@ -89,7 +94,8 @@ test_that("xportr_order: Variable are ordered when custom domain_name is passed" expect_equal(names(ordered_df), df_meta$variable) }) -test_that("xportr_order: Expect error if domain is not a character", { +## Test 6: xportr_order: Expect error if domain is not a character ---- +test_that("order Test 6: 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", @@ -101,7 +107,8 @@ test_that("xportr_order: Expect error if domain is not a character", { expect_error(xportr_order(df, df_meta, domain = 1, verbose = "none")) }) -test_that("xportr_order: error when metadata is not set", { +## Test 7: xportr_order: error when metadata is not set ---- +test_that("order Test 7: xportr_order: error when metadata is not set", { df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) expect_error( @@ -110,7 +117,8 @@ test_that("xportr_order: error when metadata is not set", { ) }) -test_that("xportr_order: Variable ordering messaging is correct", { +## Test 8: xportr_order: Variable ordering messaging is correct ---- +test_that("order Test 8: xportr_order: Variable ordering messaging is correct", { skip_if_not_installed("readxl") require(haven, quietly = TRUE) @@ -126,19 +134,20 @@ test_that("xportr_order: Variable ordering messaging is correct", { # Remove empty lines in cli theme local_cli_theme() - + suppressMessages( xportr_order(df, df_meta, verbose = "message", domain = "df") %>% expect_message("All variables in specification file are in dataset") %>% expect_condition("4 reordered in dataset") %>% - expect_message("Variable reordered in `.df`: `a`, `b`, `c`, and `d`") + expect_message("Variable reordered in `.df`: `a`, `b`, `c`, and `d`")) - xportr_order(df2, df_meta, verbose = "message", domain = "df2") %>% + suppressMessages(xportr_order(df2, df_meta, verbose = "message", domain = "df2") %>% expect_message("2 variables not in spec and moved to end") %>% expect_message("Variable moved to end in `.df`: `a` and `z`") %>% - expect_message("All variables in dataset are ordered") + expect_message("All variables in dataset are ordered")) }) -test_that("xportr_order: Metadata order columns are coersed to numeric", { +## Test 9: xportr_order: Metadata order columns are coersed to numeric ---- +test_that("order Test 9: xportr_order: Metadata order columns are coersed to numeric", { df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) df_meta <- data.frame( dataset = "df", @@ -153,25 +162,27 @@ test_that("xportr_order: Metadata order columns are coersed to numeric", { expect_equal(names(ordered_df), df_meta$variable) }) -test_that("xportr_order: Gets warning when metadata has multiple rows with same variable", { +## Test 10: xportr_order: Gets warning when metadata has multiple rows with same variable ---- +test_that("order Test 10: xportr_order: Gets warning when metadata has multiple rows with same variable", { # This test uses the (2) functions below to reduce code duplication # All `expect_*` are being called inside the functions # # Checks that message appears when xportr.domain_name is invalid - multiple_vars_in_spec_helper(xportr_order) %>% + suppressMessages(multiple_vars_in_spec_helper(xportr_order) %>% # expect_message() are being caught to provide clean test without output expect_message("All variables in specification file are in dataset") %>% - expect_message("All variables in dataset are ordered") + expect_message("All variables in dataset are ordered")) # Checks that message doesn't appear when xportr.domain_name is valid - multiple_vars_in_spec_helper2(xportr_order) %>% + suppressMessages( multiple_vars_in_spec_helper2(xportr_order) %>% # expect_message() are being caught to provide clean test without output expect_message("All variables in specification file are in dataset") %>% - expect_message("All variables in dataset are ordered") + expect_message("All variables in dataset are ordered")) }) -test_that("xportr_order: Works as expected with only one domain in metadata", { +## Test 11: xportr_order: Works as expected with only one domain in metadata ---- +test_that("order Test 11: xportr_order: Works as expected with only one domain in metadata", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) diff --git a/tests/testthat/test-pkg-load.R b/tests/testthat/test-pkg-load.R index be913992..2be6fc1e 100644 --- a/tests/testthat/test-pkg-load.R +++ b/tests/testthat/test-pkg-load.R @@ -1,4 +1,5 @@ -test_that(".onLoad: Unset options get initialised on package load with defaults", { +## Test 1: .onLoad: Unset options get initialised on package load with defaults ---- +test_that("pkg-load Test 1: .onLoad: Unset options get initialised on package load with defaults", { skip_if(getOption("testthat_interactive")) with_options( { @@ -9,7 +10,8 @@ test_that(".onLoad: Unset options get initialised on package load with defaults" ) }) -test_that(".onLoad: Initialised options are retained and not overwritten", { +## Test 2: .onLoad: Initialised options are retained and not overwritten ---- +test_that("pkg-load Test 2: .onLoad: Initialised options are retained and not overwritten", { skip_if(getOption("testthat_interactive")) with_options( { diff --git a/tests/testthat/test-support-for-tests.R b/tests/testthat/test-support-for-tests.R index 5e4136ce..de82baaf 100644 --- a/tests/testthat/test-support-for-tests.R +++ b/tests/testthat/test-support-for-tests.R @@ -1,4 +1,5 @@ -test_that("minimal_table: builds minimal data frame with data", { +## Test 1: minimal_table: builds minimal data frame with data ---- +test_that("support-for-tests Test 1: minimal_table: builds minimal data frame with data", { minimal_table(31) %>% NROW() %>% expect_equal(31) @@ -8,7 +9,8 @@ test_that("minimal_table: builds minimal data frame with data", { expect_true() }) -test_that("minimal_metadata: builds minimal metadata data frame", { +## Test 2: minimal_metadata: builds minimal metadata data frame ---- +test_that("support-for-tests Test 2: minimal_metadata: builds minimal metadata data frame", { sample_metadata <- minimal_metadata( dataset = TRUE, length = TRUE, @@ -23,7 +25,8 @@ test_that("minimal_metadata: builds minimal metadata data frame", { expect_true() }) -test_that("minimal_metadata: columns in minimal_table are all in metadata", { +## Test 3: minimal_metadata: columns in minimal_table are all in metadata ---- +test_that("support-for-tests Test 3: minimal_metadata: columns in minimal_table are all in metadata", { sample_data <- minimal_table(31, cols = c("x", "y", "z", "a", "b", "c", "d")) sample_metadata <- minimal_metadata(dataset = TRUE) (colnames(sample_data) %in% sample_metadata$variable) %>% diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R index 2bbe15de..fe686b5c 100644 --- a/tests/testthat/test-type.R +++ b/tests/testthat/test-type.R @@ -12,7 +12,8 @@ df <- data.frame( Param = c("param1", "param2", "param3") ) -test_that("xportr_type: NAs are handled as expected", { +## Test 1: xportr_type: NAs are handled as expected ---- +test_that("type Test 1: xportr_type: NAs are handled as expected", { # Namely that "" isn't converted to NA or vice versa # Numeric columns will become NA but that is the nature of as.numeric df <- data.frame( @@ -48,7 +49,8 @@ test_that("xportr_type: NAs are handled as expected", { ) }) -test_that("xportr_type: Variable types are coerced as expected and can raise messages", { +## Test 2: xportr_type: Variable types are coerced as expected and can raise messages ---- +test_that("type Test 2: xportr_type: Variable types are coerced as expected and can raise messages", { # Remove empty lines in cli theme local_cli_theme() @@ -83,7 +85,8 @@ test_that("xportr_type: Variable types are coerced as expected and can raise mes )) }) -test_that("xportr_type: Variables retain column attributes, besides class", { +## Test 3: xportr_type: Variables retain column attributes, besides class ---- +test_that("type Test 3: xportr_type: Variables retain column attributes, besides class", { adsl <- dplyr::tibble( USUBJID = c(1001, 1002, 1003), SITEID = c(001, 002, 003), @@ -128,7 +131,8 @@ test_that("xportr_type: Variables retain column attributes, besides class", { expect_equal(df_type_label, df_label_type) }) -test_that("xportr_type: expect error when domain is not a character", { +## Test 4: xportr_type: expect error when domain is not a character ---- +test_that("type Test 4: 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"), @@ -142,7 +146,8 @@ test_that("xportr_type: expect error when domain is not a character", { expect_error(xportr_type(df, df_meta, domain = NA)) }) -test_that("xportr_type: works fine from metacore spec", { +## Test 5: xportr_type: works fine from metacore spec ---- +test_that("type Test 5: xportr_type: works fine from metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = 1, y = 2) @@ -164,14 +169,16 @@ test_that("xportr_type: works fine from metacore spec", { expect_equal(processed_df$x, "1") }) -test_that("xportr_type: error when metadata is not set", { +## Test 6: xportr_type: error when metadata is not set ---- +test_that("type Test 6: xportr_type: error when metadata is not set", { expect_error( xportr_type(df), regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" ) }) -test_that("xportr_type: date variables are not converted to numeric", { +## Test 7: xportr_type: date variables are not converted to numeric ---- +test_that("type Test 7: xportr_type: date variables are not converted to numeric", { skip_if_not_installed("metacore") df <- data.frame(RFICDT = as.Date("2017-03-30"), RFICDTM = as.POSIXct("2017-03-30")) @@ -232,7 +239,8 @@ test_that("xportr_type: date variables are not converted to numeric", { expect_equal(adsl_original, adsl_xpt2) }) -test_that("xportr_type: Gets warning when metadata has multiple rows with same variable", { +## Test 8: xportr_type: Gets warning when metadata has multiple rows with same variable ---- +test_that("type Test 8: xportr_type: Gets warning when metadata has multiple rows with same variable", { # This test uses the (2) functions below to reduce code duplication # All `expect_*` are being called inside the functions # @@ -242,7 +250,8 @@ test_that("xportr_type: Gets warning when metadata has multiple rows with same v multiple_vars_in_spec_helper2(xportr_type) }) -test_that("xportr_type: Drops factor levels", { +## Test 9: xportr_type: Drops factor levels ---- +test_that("type Test 9: xportr_type: Drops factor levels", { metadata <- data.frame( dataset = "test", variable = c("Subj", "Param", "Val", "NotUsed"), @@ -279,7 +288,8 @@ metadata <- data.frame( format = c(NA, NA, "DATE9.", NA) ) -test_that("xportr_metadata: Var date types (--DTC) coerced as expected and raise messages", { +## Test 10: xportr_metadata: Var date types (--DTC) coerced as expected and raise messages ---- +test_that("type Test 10: xportr_metadata: Var date types (--DTC) coerced as expected and raise messages", { # Remove empty lines in cli theme local_cli_theme() @@ -296,7 +306,8 @@ test_that("xportr_metadata: Var date types (--DTC) coerced as expected and raise )) }) -test_that("xportr_type: Works as expected with only one domain in metadata", { +## Test 11: xportr_type: Works as expected with only one domain in metadata ---- +test_that("type Test 11: xportr_type: Works as expected with only one domain in metadata", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) diff --git a/tests/testthat/test-utils-xportr.R b/tests/testthat/test-utils-xportr.R index 7ad9c9bd..52995bb4 100644 --- a/tests/testthat/test-utils-xportr.R +++ b/tests/testthat/test-utils-xportr.R @@ -1,4 +1,5 @@ -test_that("Get magrittr lhs side value", { +## Test 1: Get magrittr lhs side value ---- +test_that("utils-xportr Test 1: Get magrittr lhs side value", { x <- function(df, var) { get_pipe_call() } @@ -24,31 +25,36 @@ test_that("Get magrittr lhs side value", { }) -test_that("fmt_vars: the message returns properly formatted variables", { +## Test 2: fmt_vars: the message returns properly formatted variables ---- +test_that("utils-xportr Test 2: 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", { +## Test 3: fmt_labs: the message returns properly formatted labels ---- +test_that("utils-xportr Test 3: 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: Get error message when the variable is over 8 characters", { +## Test 4: xpt_validate_var_names: Get error message when the variable is over 8 characters ---- +test_that("utils-xportr Test 4: 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", { +## Test 5: xpt_validate_var_names: Get error message when the variable does not start with a letter ---- +test_that("utils-xportr Test 5: 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_var_names: Get error message when the variable contains non-ASCII characters or underscore", { +## Test 6: xpt_validate_var_names: Get error message when the variable contains non-ASCII characters or underscore ---- +test_that("utils-xportr Test 6: 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( @@ -65,7 +71,8 @@ test_that("xpt_validate_var_names: Get error message when the variable contains ) }) -test_that("xpt_validate_var_names: Get error message when tje variable contains lowercase character", { +## Test 7: xpt_validate_var_names: Get error message when tje variable contains lowercase character ---- +test_that("utils-xportr Test 7: 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")), @@ -73,7 +80,8 @@ test_that("xpt_validate_var_names: Get error message when tje variable contains ) }) -test_that("xpt_validate: Get error message when the label contains over 40 characters", { +## Test 8: xpt_validate: Get error message when the label contains over 40 characters ---- +test_that("utils-xportr Test 8: xpt_validate: Get error message when the label contains over 40 characters", { df <- data.frame(A = 1, B = 2) long_label <- paste(rep("a", 41), collapse = "") attr(df$A, "label") <- long_label @@ -83,7 +91,8 @@ test_that("xpt_validate: Get error message when the label contains over 40 chara ) }) -test_that("xpt_validate: Doesn't error out with iso8601 format", { +## Test 9: xpt_validate: Doesn't error out with iso8601 format ---- +test_that("utils-xportr Test 9: xpt_validate: Doesn't error out with iso8601 format", { df <- data.frame(A = 1, B = 2) attr(df$A, "format.sas") <- "E8601LX." attr(df$B, "format.sas") <- "E8601DX20." @@ -93,7 +102,8 @@ test_that("xpt_validate: Doesn't error out with iso8601 format", { ) }) -test_that("xpt_validate: Get error message when the label contains non-ASCII, symbol or special characters", { +## Test 10: xpt_validate: Get error message when the label contains non-ASCII, symbol or special characters ---- +test_that("utils-xportr Test 10: 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çbar" expect_equal( @@ -102,7 +112,8 @@ test_that("xpt_validate: Get error message when the label contains non-ASCII, sy ) }) -test_that("xpt_validate: Get error message when the length of a character variable is > 200 bytes ", { +## Test 11: xpt_validate: Get error message when the length of a character variable is > 200 bytes ---- +test_that("utils-xportr Test 11: xpt_validate: Get error message when the length of a character variable is > 200 bytes ", { df <- data.frame(A = paste(rep("A", 201), collapse = "")) expect_equal( xpt_validate(df), @@ -110,7 +121,8 @@ test_that("xpt_validate: Get error message when the length of a character variab ) }) -test_that("xpt_validate: Get error message when the length of a non-ASCII character variable is > 200 bytes", { +## Test 12: xpt_validate: Get error message when the length of a non-ASCII character variable is > 200 bytes ---- +test_that("utils-xportr Test 12: xpt_validate: Get error message when the length of a non-ASCII character variable is > 200 bytes", { df <- data.frame(A = paste(rep("一", 67), collapse = "")) expect_equal( xpt_validate(df), @@ -118,7 +130,8 @@ test_that("xpt_validate: Get error message when the length of a non-ASCII charac ) }) -test_that("xpt_validate: Get error message when the length of a character variable is > 200 bytes and contains NAs", { +## Test 13: xpt_validate: Get error message when the length of a character variable is > 200 bytes and contains NAs ---- +test_that("utils-xportr Test 13: xpt_validate: Get error message when the length of a character variable is > 200 bytes and contains NAs", { df <- data.frame(A = c(paste(rep("A", 201), collapse = ""), NA_character_)) expect_equal( xpt_validate(df), diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index bb036cf0..af2dc0d4 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -7,7 +7,8 @@ data_to_save <- function() { # Skip large file tests unless explicitly requested test_large_files <- Sys.getenv("XPORTR.TEST_LARGE_FILES", FALSE) -test_that("xportr_write: exported data can be saved to a file", { +## Test 1: xportr_write: exported data can be saved to a file ---- +test_that("write Test 1: xportr_write: exported data can be saved to a file", { skip_if_not_installed("withr") tmp <- withr::local_file("xyz.xpt") local_data <- data_to_save() @@ -16,7 +17,8 @@ test_that("xportr_write: exported data can be saved to a file", { expect_equal(read_xpt(tmp), local_data) }) -test_that("xportr_write: exported data can still be saved to a file with a label", { +## Test 2: xportr_write: exported data can still be saved to a file with a label ---- +test_that("write Test 2: xportr_write: exported data can still be saved to a file with a label", { skip_if_not_installed("withr") tmp <- withr::local_file("xyz.xpt") @@ -30,7 +32,8 @@ test_that("xportr_write: exported data can still be saved to a file with a label expect_output(str(read_xpt(tmp)), "Lorem ipsum dolor sit amet") }) -test_that("xportr_write: exported data can be saved to a file with a metadata", { +## Test 3: xportr_write: exported data can be saved to a file with a metadata ---- +test_that("write Test 3: xportr_write: exported data can be saved to a file with a metadata", { skip_if_not_installed("withr") tmp <- withr::local_file("xyz.xpt") @@ -46,7 +49,8 @@ test_that("xportr_write: exported data can be saved to a file with a metadata", expect_output(str(read_xpt(tmp)), "Lorem ipsum dolor sit amet") }) -test_that("xportr_write: exported data can be saved to a file with a existing metadata", { +## Test 4: xportr_write: exported data can be saved to a file with a existing metadata ---- +test_that("write Test 4: xportr_write: exported data can be saved to a file with a existing metadata", { skip_if_not_installed("withr") tmp <- withr::local_file("xyz.xpt") @@ -63,7 +67,8 @@ test_that("xportr_write: exported data can be saved to a file with a existing me expect_output(str(read_xpt(tmp)), "Lorem ipsum dolor sit amet") }) -test_that("xportr_write: expect error when invalid multibyte string is passed in label", { +## Test 5: xportr_write: expect error when invalid multibyte string is passed in label ---- +test_that("write Test 5: xportr_write: expect error when invalid multibyte string is passed in label", { skip_if_not_installed("withr") expect_error( xportr_write( @@ -77,7 +82,8 @@ test_that("xportr_write: expect error when invalid multibyte string is passed in ) }) -test_that("xportr_write: expect error when file name is over 8 characters long", { +## Test 6: xportr_write: expect error when file name is over 8 characters long ---- +test_that("write Test 6: xportr_write: expect error when file name is over 8 characters long", { skip_if_not_installed("withr") expect_error( xportr_write( @@ -88,7 +94,8 @@ test_that("xportr_write: expect error when file name is over 8 characters long", ) }) -test_that("xportr_write: expect error when file name contains non-ASCII symbols or special characters", { +## Test 7: xportr_write: expect error when file name contains non-ASCII symbols or special characters ---- +test_that("write Test 7: xportr_write: expect error when file name contains non-ASCII symbols or special characters", { skip_if_not_installed("withr") expect_error( xportr_write(data_to_save(), withr::local_file(".xpt"), strict_checks = TRUE), @@ -96,7 +103,8 @@ test_that("xportr_write: expect error when file name contains non-ASCII symbols ) }) -test_that("xportr_write: expect warning when file name contains underscore and strict_checks = FALSE", { +## Test 8: xportr_write: expect warning when file name contains underscore and strict_checks = FALSE ---- +test_that("write Test 8: xportr_write: expect warning when file name contains underscore and strict_checks = FALSE", { skip_if_not_installed("withr") expect_warning( xportr_write(data_to_save(), withr::local_file("test_.xpt"), strict_checks = FALSE), @@ -104,7 +112,8 @@ test_that("xportr_write: expect warning when file name contains underscore and s ) }) -test_that("xportr_write: expect error when label contains non-ASCII symbols or special characters", { +## Test 9: xportr_write: expect error when label contains non-ASCII symbols or special characters ---- +test_that("write Test 9: xportr_write: expect error when label contains non-ASCII symbols or special characters", { skip_if_not_installed("withr") expect_error( xportr_write( @@ -120,7 +129,8 @@ test_that("xportr_write: expect error when label contains non-ASCII symbols or s ) }) -test_that("xportr_write: expect error when label is over 40 characters", { +## Test 10: xportr_write: expect error when label is over 40 characters ---- +test_that("write Test 10: xportr_write: expect error when label is over 40 characters", { skip_if_not_installed("withr") expect_error( xportr_write( @@ -136,7 +146,8 @@ test_that("xportr_write: expect error when label is over 40 characters", { ) }) -test_that("xportr_write: expect error when an xpt validation fails with strict_checks set to TRUE", { +## Test 11: xportr_write: expect error when an xpt validation fails with strict_checks set to TRUE ---- +test_that("write Test 11: xportr_write: expect error when an xpt validation fails with strict_checks set to TRUE", { skip_if_not_installed("withr") local_data <- data_to_save() attr(local_data$X, "format.sas") <- "foo" @@ -156,7 +167,8 @@ test_that("xportr_write: expect error when an xpt validation fails with strict_c ) }) -test_that("xportr_write: expect warning when an xpt validation fails with strict_checks set to FALSE", { +## Test 12: xportr_write: expect warning when an xpt validation fails with strict_checks set to FALSE ---- +test_that("write Test 12: xportr_write: expect warning when an xpt validation fails with strict_checks set to FALSE", { skip_if_not_installed("withr") local_data <- data_to_save() attr(local_data$X, "format.sas") <- "foo" @@ -176,7 +188,8 @@ test_that("xportr_write: expect warning when an xpt validation fails with strict ) }) -test_that("xportr_write: Capture errors by haven and report them as such", { +## Test 13: xportr_write: Capture errors by haven and report them as such ---- +test_that("write Test 13: xportr_write: Capture errors by haven and report them as such", { skip_if_not_installed("withr") local_data <- data_to_save() attr(local_data$X, "format.sas") <- "E8601LXw.asdf" @@ -198,7 +211,8 @@ test_that("xportr_write: Capture errors by haven and report them as such", { ) }) -test_that("xportr_write: `split_by` attribute is used to split the data", { +## Test 14: xportr_write: `split_by` attribute is used to split the data ---- +test_that("write Test 14: xportr_write: `split_by` attribute is used to split the data", { tmpdir <- tempdir() tmp <- file.path(tmpdir, "xyz.xpt") @@ -241,7 +255,8 @@ test_that("xportr_write: `split_by` attribute is used to split the data", { ) }) -test_that("xportr_write: Large file sizes are reported and warned", { +## Test 15: xportr_write: Large file sizes are reported and warned ---- +test_that("write Test 15: xportr_write: Large file sizes are reported and warned", { skip_if_not(test_large_files) tmpdir <- tempdir() tmp <- file.path(tmpdir, "xyz.xpt") diff --git a/tests/testthat/test-xportr.R b/tests/testthat/test-xportr.R index 975b45a1..5c235244 100644 --- a/tests/testthat/test-xportr.R +++ b/tests/testthat/test-xportr.R @@ -1,7 +1,5 @@ -test_that("pipeline results match `xportr()` results", { - - if (requireNamespace("magrittr", quietly = TRUE)) { - +## Test 1: pipeline results match `xportr()` results ---- +test_that("xportr Test 1: pipeline results match `xportr()` results", { data("var_spec", "dataset_spec", "adsl_xportr", envir = environment()) adsl <- adsl_xportr @@ -45,5 +43,4 @@ test_that("pipeline results match `xportr()` results", { haven::read_xpt(pipeline_path), haven::read_xpt(xportr_path) ) - } }) From b247ba31bce26a4034f860685514d0a8b920beca Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Wed, 6 Mar 2024 02:25:20 -0500 Subject: [PATCH 4/9] updating documentations --- R/addin_format_testthat.R | 107 -------------------------------------- man/metadata.Rd | 2 +- man/xportr_df_label.Rd | 2 +- man/xportr_format.Rd | 2 +- man/xportr_label.Rd | 2 +- man/xportr_length.Rd | 2 +- man/xportr_order.Rd | 2 +- man/xportr_type.Rd | 2 +- man/xportr_write.Rd | 2 +- 9 files changed, 8 insertions(+), 115 deletions(-) delete mode 100644 R/addin_format_testthat.R diff --git a/R/addin_format_testthat.R b/R/addin_format_testthat.R deleted file mode 100644 index df6c5b0a..00000000 --- a/R/addin_format_testthat.R +++ /dev/null @@ -1,107 +0,0 @@ -# Returns the call for updating a given test_that test file -# by adding a function name, a test number, and a section. -# Call the function either by using RStudio Addin "format_test_that_file" or -# programmatically in a for loop on the test files and running -# rstudioapi::navigateToFile and format_test_that_file -prepare_test_that_file <- function(path) { - assert_character_scalar(path) - - # check that file exists - if (!file.exists(path)) { - stop("Invalid file path, the file does not exist.") - } - - # check that testthat is used and testing file is opened - uses_test_file <- grepl("tests/testthat/test-", path, fixed = TRUE) - if (!uses_test_file) { - stop("This Addin works only on unit test files that follow a testthat structure.") - } - - # parse the name of the testing function - testing_file <- sub("^test-", "", sub(".R$", "", basename(path))) - - # get file content - file_content <- readLines(path) - - # get locations of tests - match 'test_that("' strings - test_that_loc <- grep('^test_that\\("', file_content) - - if (length(test_that_loc) == 0) { - return(invisible(NULL)) - } - - #### - ## HANDLE test_that DESCRIPTIONS - #### - - # get and parse test descriptions - test_that_lines <- file_content[test_that_loc] - test_that_desc_parsed <- stringr::str_extract( - string = test_that_lines, - pattern = paste0( - '(?<=test_that\\(")', # positive look-ahead - search matching expression after test_that(" - ".*", # matching expression - match everything - '(?=")' # positive look-behind - search matching expression before " - ) - ) - test_that_desc_cleaned <- stringr::str_remove( - string = test_that_desc_parsed, - pattern = paste0("([\\w\\.]+,? )?[Tt]est \\d{1,} ?: ") - ) - - # determine name of function which is tested - # the function name can be specified by # function_name ---- comments - function_name <- str_match(file_content, "# ([\\w\\.]+) ----")[, 2] - if (is.na(function_name[1])) { - function_name[1] <- testing_file - } - function_name <- tidyr::fill(data.frame(name = function_name), name)$name - function_name <- function_name[test_that_loc] - - # formulate new test descriptions (update only those that don't include test_title) - new_desc <- paste0( - "Test ", seq_along(test_that_loc), ": ", - test_that_desc_cleaned - ) - - # insert new test descriptions into test_that lines - test_that_lines_updated <- stringr::str_replace( - string = test_that_lines, - pattern = '(?<=test_that\\(").*"', - replacement = paste0(function_name, " ", new_desc, '"') - ) - - # modify the file content - file_content[test_that_loc] <- test_that_lines_updated - - #### - ## HANDLE HEADERS - #### - - # formulate headers according to RStudio editor functionality - headers <- paste0("## ", new_desc, " ----") - - # get locations of headers created by this function - header_loc_lgl <- grepl(paste0("^##?( ----)?( \\w+)?,? [tT]est \\d{1,} ?: "), file_content) - - # remove those headers - file_content <- file_content[!header_loc_lgl] - - # add new headers just before test_that calls - header_loc <- grep('^test_that\\("', file_content) + seq_along(headers) - 1 - file_content_new <- vector(mode = "character", length = length(file_content) + length(headers)) - file_content_new[header_loc] <- headers - file_content_new[-header_loc] <- file_content - - list(file_content = file_content_new) -} - -# Function for the RStudio Addin, see inst/rstudio/addins.dcf. -# Wrapper of prepare_test_that_file. -format_test_that_file <- function() { - file_info <- rstudioapi::getActiveDocumentContext() - rstudioapi::documentSave(id = file_info$id) - result <- prepare_test_that_file(path = file_info$path) - rstudioapi::setDocumentContents(paste0(result$file_content, collapse = "\n"), id = file_info$id) - rstudioapi::documentSave(id = file_info$id) -} diff --git a/man/metadata.Rd b/man/metadata.Rd index 01942fa0..cd286905 100644 --- a/man/metadata.Rd +++ b/man/metadata.Rd @@ -12,7 +12,7 @@ xportr_metadata(.df, metadata = NULL, domain = NULL, verbose = NULL) \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_df_label.Rd b/man/xportr_df_label.Rd index 691de990..5f95d771 100644 --- a/man/xportr_df_label.Rd +++ b/man/xportr_df_label.Rd @@ -12,7 +12,7 @@ xportr_df_label(.df, metadata = NULL, domain = NULL, metacore = deprecated()) \item{metadata}{A data frame containing dataset. See 'Metadata' section for details.} -\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_format.Rd b/man/xportr_format.Rd index c1e1fe16..e45f66dc 100644 --- a/man/xportr_format.Rd +++ b/man/xportr_format.Rd @@ -18,7 +18,7 @@ xportr_format( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_label.Rd b/man/xportr_label.Rd index eb03df81..a61e0583 100644 --- a/man/xportr_label.Rd +++ b/man/xportr_label.Rd @@ -18,7 +18,7 @@ xportr_label( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_length.Rd b/man/xportr_length.Rd index a2c2e01e..c3180a71 100644 --- a/man/xportr_length.Rd +++ b/man/xportr_length.Rd @@ -19,7 +19,7 @@ xportr_length( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_order.Rd b/man/xportr_order.Rd index 26b87f42..03617d4f 100644 --- a/man/xportr_order.Rd +++ b/man/xportr_order.Rd @@ -18,7 +18,7 @@ xportr_order( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_type.Rd b/man/xportr_type.Rd index 736fe0c6..05489fcf 100644 --- a/man/xportr_type.Rd +++ b/man/xportr_type.Rd @@ -18,7 +18,7 @@ xportr_type( \item{metadata}{A data frame containing variable level metadata. See 'Metadata' section for details.} -\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} diff --git a/man/xportr_write.Rd b/man/xportr_write.Rd index c6bd4a1d..bde66844 100644 --- a/man/xportr_write.Rd +++ b/man/xportr_write.Rd @@ -22,7 +22,7 @@ used as \code{xpt} name.} \item{metadata}{A data frame containing dataset. See 'Metadata' section for details.} -\item{domain}{Appropriate CDSIC dataset name, e.g. ADAE, DM. Used to subset +\item{domain}{Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the metadata object. If none is passed, then name of the dataset passed as .df will be used.} From 274c88e94fd9f1710da0a3ebf617160401af7407 Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Wed, 6 Mar 2024 02:35:55 -0500 Subject: [PATCH 5/9] Fixing the code style --- tests/testthat/test-deprecation.R | 58 +++++++++++--------- tests/testthat/test-label.R | 26 ++++----- tests/testthat/test-metadata.R | 88 +++++++++++++++---------------- tests/testthat/test-order.R | 11 ++-- tests/testthat/test-xportr.R | 68 ++++++++++++------------ 5 files changed, 129 insertions(+), 122 deletions(-) diff --git a/tests/testthat/test-deprecation.R b/tests/testthat/test-deprecation.R index e3e1f34b..23d7c55a 100644 --- a/tests/testthat/test-deprecation.R +++ b/tests/testthat/test-deprecation.R @@ -1,24 +1,24 @@ ## Test 1: xportr_df_label: deprecated metacore gives an error ---- -test_that("deprecation Test 1: xportr_df_label: deprecated metacore gives an error", - { - local_options(lifecycle_verbosity = "quiet") - df <- data.frame(x = "a", y = "b") - df_meta <- data.frame(dataset = "df", label = "Label") +test_that("deprecation Test 1: xportr_df_label: deprecated metacore gives an error", { + local_options(lifecycle_verbosity = "quiet") + df <- data.frame(x = "a", y = "b") + df_meta <- data.frame(dataset = "df", label = "Label") - expect_error(xportr_df_label(df, metacore = df_meta)) - }) + expect_error(xportr_df_label(df, metacore = df_meta)) +}) ## Test 2: xportr_format: deprecated metacore gives an error ---- -test_that("deprecation Test 2: xportr_format: deprecated metacore gives an error", - { - local_options(lifecycle_verbosity = "quiet") - df <- data.frame(x = 1, y = 2) - df_meta <- data.frame(dataset = "df", - variable = "x", - format = "date9.") +test_that("deprecation Test 2: xportr_format: deprecated metacore gives an error", { + local_options(lifecycle_verbosity = "quiet") + df <- data.frame(x = 1, y = 2) + df_meta <- data.frame( + dataset = "df", + variable = "x", + format = "date9." + ) - expect_error(xportr_format(df, metacore = df_meta)) - }) + expect_error(xportr_format(df, metacore = df_meta)) +}) ## Test 3: xportr_label: using the deprecated metacore argument gives an error ---- test_that( @@ -28,9 +28,11 @@ test_that( df <- data.frame(x = "a", y = "b") df_meta <- - data.frame(dataset = "df", - variable = "x", - label = "foo") + data.frame( + dataset = "df", + variable = "x", + label = "foo" + ) expect_error(xportr_label(df, metacore = df_meta)) } @@ -59,13 +61,17 @@ test_that( { local_options(lifecycle_verbosity = "quiet") - 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) + 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 + ) expect_error(xportr_order(df, metacore = df_meta, domain = "DOMAIN")) } diff --git a/tests/testthat/test-label.R b/tests/testthat/test-label.R index 88b52a3f..0155a49e 100644 --- a/tests/testthat/test-label.R +++ b/tests/testthat/test-label.R @@ -8,7 +8,8 @@ test_that("label Test 1: xportr_label: error when metadata is not set", { ) expect_error(xportr_label(df), - regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'") + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" + ) }) ## Test 2: xportr_label: Gets warning when metadata has multiple rows with same variable ---- @@ -27,16 +28,17 @@ test_that( ## Test 3: xportr_label: Works as expected with only one domain in metadata ---- -test_that("label Test 3: xportr_label: Works as expected with only one domain in metadata", - { - adsl <- data.frame(USUBJID = c(1001, 1002, 1003), - BRTHDT = c(1, 1, 2)) +test_that("label Test 3: xportr_label: Works as expected with only one domain in metadata", { + adsl <- data.frame( + USUBJID = c(1001, 1002, 1003), + BRTHDT = c(1, 1, 2) + ) - metadata <- data.frame( - dataset = c("adsl", "adsl"), - variable = c("USUBJID", "BRTHDT"), - label = c("Hello", "Hello2") - ) + metadata <- data.frame( + dataset = c("adsl", "adsl"), + variable = c("USUBJID", "BRTHDT"), + label = c("Hello", "Hello2") + ) - expect_silent(xportr_label(adsl, metadata)) - }) + expect_silent(xportr_label(adsl, metadata)) +}) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index b09e9ab4..3baeb02a 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -608,11 +608,11 @@ test_that("metadata Test 28: xportr_metadata: Throws message when variables not ## Test 29: xportr_metadata: Variable ordering messaging is correct ---- test_that("metadata Test 29: xportr_metadata: Variable ordering messaging is correct", { - #skip_if_not_installed("haven") - #skip_if_not_installed("readxl") + # skip_if_not_installed("haven") + # skip_if_not_installed("readxl") - #require(haven, quietly = TRUE) - #require(readxl, quietly = TRUE) + # require(haven, quietly = TRUE) + # require(readxl, quietly = TRUE) df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) df2 <- data.frame(a = "a", z = "z") @@ -793,51 +793,49 @@ test_that("metadata Test 33: xportr_*: Domain is kept in between calls", { ## Test 34: `xportr_metadata()` results match traditional results ---- test_that("metadata Test 34: `xportr_metadata()` results match traditional results", { - data("var_spec", "dataset_spec", "adsl_xportr", envir = environment()) adsl <- adsl_xportr - skip_if_not_installed("withr") - trad_path <- withr::local_file("adsltrad.xpt") - metadata_path <- withr::local_file("adslmeta.xpt") - - dataset_spec_low <- setNames(dataset_spec, tolower(names(dataset_spec))) - names(dataset_spec_low)[[2]] <- "label" - - var_spec_low <- setNames(var_spec, tolower(names(var_spec))) - names(var_spec_low)[[5]] <- "type" - - metadata_df <- adsl %>% - xportr_metadata(var_spec_low, "ADSL", verbose = "none") %>% - xportr_type() %>% - xportr_length() %>% - xportr_label() %>% - xportr_order() %>% - xportr_format() %>% - xportr_df_label(dataset_spec_low) %>% - xportr_write(metadata_path) - - trad_df <- adsl %>% - xportr_type(var_spec_low, "ADSL", verbose = "none") %>% - xportr_length(var_spec_low, "ADSL", verbose = "none") %>% - xportr_label(var_spec_low, "ADSL", verbose = "none") %>% - xportr_order(var_spec_low, "ADSL", verbose = "none") %>% - xportr_format(var_spec_low, "ADSL") %>% - xportr_df_label(dataset_spec_low, "ADSL") %>% - xportr_write(trad_path) - - expect_identical( - metadata_df, - structure( - trad_df, - `_xportr.df_metadata_` = var_spec_low, - `_xportr.df_verbose_` = "none" - ) - ) + skip_if_not_installed("withr") + trad_path <- withr::local_file("adsltrad.xpt") + metadata_path <- withr::local_file("adslmeta.xpt") - expect_identical( - haven::read_xpt(metadata_path), - haven::read_xpt(trad_path) + dataset_spec_low <- setNames(dataset_spec, tolower(names(dataset_spec))) + names(dataset_spec_low)[[2]] <- "label" + + var_spec_low <- setNames(var_spec, tolower(names(var_spec))) + names(var_spec_low)[[5]] <- "type" + + metadata_df <- adsl %>% + xportr_metadata(var_spec_low, "ADSL", verbose = "none") %>% + xportr_type() %>% + xportr_length() %>% + xportr_label() %>% + xportr_order() %>% + xportr_format() %>% + xportr_df_label(dataset_spec_low) %>% + xportr_write(metadata_path) + + trad_df <- adsl %>% + xportr_type(var_spec_low, "ADSL", verbose = "none") %>% + xportr_length(var_spec_low, "ADSL", verbose = "none") %>% + xportr_label(var_spec_low, "ADSL", verbose = "none") %>% + xportr_order(var_spec_low, "ADSL", verbose = "none") %>% + xportr_format(var_spec_low, "ADSL") %>% + xportr_df_label(dataset_spec_low, "ADSL") %>% + xportr_write(trad_path) + + expect_identical( + metadata_df, + structure( + trad_df, + `_xportr.df_metadata_` = var_spec_low, + `_xportr.df_verbose_` = "none" ) + ) + expect_identical( + haven::read_xpt(metadata_path), + haven::read_xpt(trad_path) + ) }) diff --git a/tests/testthat/test-order.R b/tests/testthat/test-order.R index e7688e65..05c8cd77 100644 --- a/tests/testthat/test-order.R +++ b/tests/testthat/test-order.R @@ -135,10 +135,11 @@ test_that("order Test 8: xportr_order: Variable ordering messaging is correct", # Remove empty lines in cli theme local_cli_theme() suppressMessages( - xportr_order(df, df_meta, verbose = "message", domain = "df") %>% - expect_message("All variables in specification file are in dataset") %>% - expect_condition("4 reordered in dataset") %>% - expect_message("Variable reordered in `.df`: `a`, `b`, `c`, and `d`")) + xportr_order(df, df_meta, verbose = "message", domain = "df") %>% + expect_message("All variables in specification file are in dataset") %>% + expect_condition("4 reordered in dataset") %>% + expect_message("Variable reordered in `.df`: `a`, `b`, `c`, and `d`") + ) suppressMessages(xportr_order(df2, df_meta, verbose = "message", domain = "df2") %>% expect_message("2 variables not in spec and moved to end") %>% @@ -174,7 +175,7 @@ test_that("order Test 10: xportr_order: Gets warning when metadata has multiple expect_message("All variables in dataset are ordered")) # Checks that message doesn't appear when xportr.domain_name is valid - suppressMessages( multiple_vars_in_spec_helper2(xportr_order) %>% + suppressMessages(multiple_vars_in_spec_helper2(xportr_order) %>% # expect_message() are being caught to provide clean test without output expect_message("All variables in specification file are in dataset") %>% expect_message("All variables in dataset are ordered")) diff --git a/tests/testthat/test-xportr.R b/tests/testthat/test-xportr.R index 5c235244..17d6cc9f 100644 --- a/tests/testthat/test-xportr.R +++ b/tests/testthat/test-xportr.R @@ -3,44 +3,44 @@ test_that("xportr Test 1: pipeline results match `xportr()` results", { data("var_spec", "dataset_spec", "adsl_xportr", envir = environment()) adsl <- adsl_xportr - skip_if_not_installed("withr") - pipeline_path <- withr::local_file("adslpipe.xpt") - xportr_path <- withr::local_file("adslxptr.xpt") + skip_if_not_installed("withr") + pipeline_path <- withr::local_file("adslpipe.xpt") + xportr_path <- withr::local_file("adslxptr.xpt") - dataset_spec_low <- setNames(dataset_spec, tolower(names(dataset_spec))) - names(dataset_spec_low)[[2]] <- "label" + dataset_spec_low <- setNames(dataset_spec, tolower(names(dataset_spec))) + names(dataset_spec_low)[[2]] <- "label" - var_spec_low <- setNames(var_spec, tolower(names(var_spec))) - names(var_spec_low)[[5]] <- "type" + var_spec_low <- setNames(var_spec, tolower(names(var_spec))) + names(var_spec_low)[[5]] <- "type" - # Divert all messages to tempfile, instead of printing them - # note: be aware as this should only be used in tests that don't track - # messages - withr::local_message_sink(withr::local_tempfile()) - pipeline_df <- adsl %>% - xportr_metadata(var_spec_low, "ADSL", verbose = "none") %>% - xportr_type() %>% - xportr_length() %>% - xportr_label() %>% - xportr_order() %>% - xportr_format() %>% - xportr_df_label(dataset_spec_low) %>% - xportr_write(pipeline_path) + # Divert all messages to tempfile, instead of printing them + # note: be aware as this should only be used in tests that don't track + # messages + withr::local_message_sink(withr::local_tempfile()) + pipeline_df <- adsl %>% + xportr_metadata(var_spec_low, "ADSL", verbose = "none") %>% + xportr_type() %>% + xportr_length() %>% + xportr_label() %>% + xportr_order() %>% + xportr_format() %>% + xportr_df_label(dataset_spec_low) %>% + xportr_write(pipeline_path) - # `xportr()` can be used to apply a whole pipeline at once - xportr_df <- xportr( - adsl, - var_metadata = var_spec_low, - df_metadata = dataset_spec_low, - domain = "ADSL", - verbose = "none", - path = xportr_path - ) + # `xportr()` can be used to apply a whole pipeline at once + xportr_df <- xportr( + adsl, + var_metadata = var_spec_low, + df_metadata = dataset_spec_low, + domain = "ADSL", + verbose = "none", + path = xportr_path + ) - expect_identical(pipeline_df, xportr_df) + expect_identical(pipeline_df, xportr_df) - expect_identical( - haven::read_xpt(pipeline_path), - haven::read_xpt(xportr_path) - ) + expect_identical( + haven::read_xpt(pipeline_path), + haven::read_xpt(xportr_path) + ) }) From 29578156929e53c7cd050b188311722e3bd719ab Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Wed, 6 Mar 2024 02:41:39 -0500 Subject: [PATCH 6/9] fixing styler --- tests/testthat/test-length.R | 262 +++++++++++++++++---------------- tests/testthat/test-messages.R | 118 ++++++++------- 2 files changed, 193 insertions(+), 187 deletions(-) diff --git a/tests/testthat/test-length.R b/tests/testthat/test-length.R index b21f5e2b..f087a92a 100644 --- a/tests/testthat/test-length.R +++ b/tests/testthat/test-length.R @@ -6,47 +6,48 @@ #' variable) ## Test 1: xportr_length: Accepts valid domain names in metadata object ---- -test_that("length Test 1: xportr_length: Accepts valid domain names in metadata object", - { - adsl <- minimal_table(30) - metadata <- - minimal_metadata(dataset = TRUE, - length = TRUE, - var_names = colnames(adsl)) - - # Setup temporary options with active verbose - local_options(xportr.length_verbose = "message") - - # Test minimal call with valid data and without domain - adsl %>% - xportr_metadata(domain = "adsl") %>% - xportr_length(metadata) %>% - expect_silent() %>% - expect_attr_width(metadata$length) - - # Test minimal call with valid data with a valid domain - xportr_length(adsl, metadata, domain = "adsl") %>% - expect_silent() %>% - expect_attr_width(metadata$length) %>% - NROW() %>% - expect_equal(30) - - # Test minimal call without datasets - metadata_without_dataset <- metadata %>% select(-"dataset") - - xportr_length(adsl, metadata_without_dataset, domain = "adsl") %>% - expect_silent() %>% - expect_attr_width(metadata_without_dataset$length) %>% - NROW() %>% - expect_equal(30) - - # Test minimal call without datasets and ignores domain - xportr_length(adsl, metadata_without_dataset, domain = "something_else") %>% - expect_silent() %>% - expect_attr_width(metadata_without_dataset$length) %>% - NROW() %>% - expect_equal(30) - }) +test_that("length Test 1: xportr_length: Accepts valid domain names in metadata object", { + adsl <- minimal_table(30) + metadata <- + minimal_metadata( + dataset = TRUE, + length = TRUE, + var_names = colnames(adsl) + ) + + # Setup temporary options with active verbose + local_options(xportr.length_verbose = "message") + + # Test minimal call with valid data and without domain + adsl %>% + xportr_metadata(domain = "adsl") %>% + xportr_length(metadata) %>% + expect_silent() %>% + expect_attr_width(metadata$length) + + # Test minimal call with valid data with a valid domain + xportr_length(adsl, metadata, domain = "adsl") %>% + expect_silent() %>% + expect_attr_width(metadata$length) %>% + NROW() %>% + expect_equal(30) + + # Test minimal call without datasets + metadata_without_dataset <- metadata %>% select(-"dataset") + + xportr_length(adsl, metadata_without_dataset, domain = "adsl") %>% + expect_silent() %>% + expect_attr_width(metadata_without_dataset$length) %>% + NROW() %>% + expect_equal(30) + + # Test minimal call without datasets and ignores domain + xportr_length(adsl, metadata_without_dataset, domain = "something_else") %>% + expect_silent() %>% + expect_attr_width(metadata_without_dataset$length) %>% + NROW() %>% + expect_equal(30) +}) ## Test 2: xportr_length: CDISC data frame is being piped after another xportr function ---- test_that( @@ -75,65 +76,67 @@ test_that( ) ## Test 3: xportr_length: Impute character lengths based on class ---- -test_that("length Test 3: xportr_length: Impute character lengths based on class", - { - adsl <- minimal_table(30, cols = c("x", "b")) - metadata <- minimal_metadata(dataset = TRUE, - length = TRUE, - var_names = colnames(adsl)) %>% - mutate(length = length - 1) - - # Setup temporary options with `verbose = "none"` - local_options(xportr.length_verbose = "none") - # Define controlled `character_types` for this test - local_options(xportr.character_types = c("character", "date")) - - # Remove empty lines in cli theme - local_cli_theme() - - # Test length imputation of character and numeric (not valid character type) - result <- adsl %>% - xportr_length(metadata, domain = "adsl") %>% - expect_silent() - - expect_attr_width(result, c(7, 199)) - - # Test length imputation of two valid character types (both should have - # `width = 200``) - adsl <- adsl %>% - mutate( - new_date = as.Date(.data$x, origin = "1970-01-01"), - new_char = as.character(.data$b), - new_num = as.numeric(.data$x) - ) - - adsl %>% - xportr_length(metadata, domain = "adsl") %>% - expect_message("Variable lengths missing from metadata") %>% - expect_message("lengths resolved") %>% - expect_attr_width(c(7, 199, 200, 200, 8)) - }) +test_that("length Test 3: xportr_length: Impute character lengths based on class", { + adsl <- minimal_table(30, cols = c("x", "b")) + metadata <- minimal_metadata( + dataset = TRUE, + length = TRUE, + var_names = colnames(adsl) + ) %>% + mutate(length = length - 1) + + # Setup temporary options with `verbose = "none"` + local_options(xportr.length_verbose = "none") + # Define controlled `character_types` for this test + local_options(xportr.character_types = c("character", "date")) + + # Remove empty lines in cli theme + local_cli_theme() + + # Test length imputation of character and numeric (not valid character type) + result <- adsl %>% + xportr_length(metadata, domain = "adsl") %>% + expect_silent() + + expect_attr_width(result, c(7, 199)) + + # Test length imputation of two valid character types (both should have + # `width = 200``) + adsl <- adsl %>% + mutate( + new_date = as.Date(.data$x, origin = "1970-01-01"), + new_char = as.character(.data$b), + new_num = as.numeric(.data$x) + ) + + adsl %>% + xportr_length(metadata, domain = "adsl") %>% + expect_message("Variable lengths missing from metadata") %>% + expect_message("lengths resolved") %>% + expect_attr_width(c(7, 199, 200, 200, 8)) +}) ## Test 4: xportr_length: Throws message when variables not present in metadata ---- -test_that("length Test 4: xportr_length: Throws message when variables not present in metadata", - { - adsl <- minimal_table(30, cols = c("x", "y")) - metadata <- - minimal_metadata(dataset = TRUE, - length = TRUE, - var_names = c("x")) - - # Setup temporary options with `verbose = "message"` - local_options(xportr.length_verbose = "message") - # Remove empty lines in cli theme - local_cli_theme() - - # Test that message is given which indicates that variable is not present - xportr_length(adsl, metadata, domain = "adsl") %>% - expect_message("Variable lengths missing from metadata") %>% - expect_message("lengths resolved") %>% - expect_message(regexp = "Problem with `y`") - }) +test_that("length Test 4: xportr_length: Throws message when variables not present in metadata", { + adsl <- minimal_table(30, cols = c("x", "y")) + metadata <- + minimal_metadata( + dataset = TRUE, + length = TRUE, + var_names = c("x") + ) + + # Setup temporary options with `verbose = "message"` + local_options(xportr.length_verbose = "message") + # Remove empty lines in cli theme + local_cli_theme() + + # Test that message is given which indicates that variable is not present + xportr_length(adsl, metadata, domain = "adsl") %>% + expect_message("Variable lengths missing from metadata") %>% + expect_message("lengths resolved") %>% + expect_message(regexp = "Problem with `y`") +}) ## Test 5: xportr_length: Metacore instance can be used ---- test_that("length Test 5: xportr_length: Metacore instance can be used", { @@ -144,8 +147,10 @@ test_that("length Test 5: xportr_length: Metacore instance can be used", { metadata <- suppressMessages(suppressWarnings( metacore::metacore( ds_spec = dplyr::tibble(dataset = "ADSL"), - ds_vars = dplyr::tibble(dataset = "ADSL", - variable = colnames(adsl)), + ds_vars = dplyr::tibble( + dataset = "ADSL", + variable = colnames(adsl) + ), var_spec = minimal_metadata( length = TRUE, type = TRUE, @@ -184,7 +189,8 @@ test_that("length Test 7: xportr_length: error when metadata is not set", { adsl <- minimal_table(30) expect_error(xportr_length(adsl), - regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'") + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" + ) }) ## Test 8: xportr_length: Gets warning when metadata has multiple rows with same variable ---- @@ -207,21 +213,22 @@ meta_example <- data.frame( length = c(10, 8) ) -df <- data.frame(USUBJID = c("1", "12", "123"), - WEIGHT = c(85, 45, 121)) +df <- data.frame( + USUBJID = c("1", "12", "123"), + WEIGHT = c(85, 45, 121) +) ## Test 9: xportr_length: length assigned as expected from metadata or data ---- -test_that("length Test 9: xportr_length: length assigned as expected from metadata or data", - { - result <- df %>% - xportr_length(meta_example, domain = "df", length_source = "metadata") %>% - expect_attr_width(c(10, 8)) - suppressMessages( - result <- df %>% - xportr_length(meta_example, domain = "df", length_source = "data") %>% - expect_attr_width(c(3, 8)) - ) - }) +test_that("length Test 9: xportr_length: length assigned as expected from metadata or data", { + result <- df %>% + xportr_length(meta_example, domain = "df", length_source = "metadata") %>% + expect_attr_width(c(10, 8)) + suppressMessages( + result <- df %>% + xportr_length(meta_example, domain = "df", length_source = "data") %>% + expect_attr_width(c(3, 8)) + ) +}) ## Test 10: xportr_length: Gets message when length in metadata longer than data length ---- test_that( @@ -234,16 +241,17 @@ test_that( ) ## Test 11: xportr_length: Works as expected with only one domain in metadata ---- -test_that("length Test 11: xportr_length: Works as expected with only one domain in metadata", - { - adsl <- data.frame(USUBJID = c(1001, 1002, 1003), - BRTHDT = c(1, 1, 2)) - - metadata <- data.frame( - dataset = c("adsl", "adsl"), - variable = c("USUBJID", "BRTHDT"), - length = c(1, 1) - ) - - expect_silent(xportr_length(adsl, metadata)) - }) +test_that("length Test 11: xportr_length: Works as expected with only one domain in metadata", { + adsl <- data.frame( + USUBJID = c(1001, 1002, 1003), + BRTHDT = c(1, 1, 2) + ) + + metadata <- data.frame( + dataset = c("adsl", "adsl"), + variable = c("USUBJID", "BRTHDT"), + length = c(1, 1) + ) + + expect_silent(xportr_length(adsl, metadata)) +}) diff --git a/tests/testthat/test-messages.R b/tests/testthat/test-messages.R index b8b14e79..a54b39bc 100644 --- a/tests/testthat/test-messages.R +++ b/tests/testthat/test-messages.R @@ -1,77 +1,75 @@ #' Test `R/messages.R` functions ## Test 1: xportr_logger: Type parameter will create correct message type ---- -test_that("messages Test 1: xportr_logger: Type parameter will create correct message type", - { - xportr_logger("A message", type = "none") %>% - expect_silent() +test_that("messages Test 1: xportr_logger: Type parameter will create correct message type", { + xportr_logger("A message", type = "none") %>% + expect_silent() - xportr_logger("A message", type = "message") %>% - expect_message("A message") + xportr_logger("A message", type = "message") %>% + expect_message("A message") - xportr_logger("A message", type = "warn") %>% - expect_warning("A message") + xportr_logger("A message", type = "warn") %>% + expect_warning("A message") - xportr_logger("A message", type = "stop") %>% - expect_error("A message") + xportr_logger("A message", type = "stop") %>% + expect_error("A message") - # Supports additional parameters to rlang::stop - xportr_logger("A message", type = "stop", footer = "A footer") %>% - expect_error("A message", class = "rlang_error") - }) + # Supports additional parameters to rlang::stop + xportr_logger("A message", type = "stop", footer = "A footer") %>% + expect_error("A message", class = "rlang_error") +}) ## Test 2: length_log: Missing lengths messages are shown ---- -test_that("messages Test 2: length_log: Missing lengths messages are shown", - { - # Remove empty lines in cli theme - local_cli_theme() +test_that("messages Test 2: length_log: Missing lengths messages are shown", { + # Remove empty lines in cli theme + local_cli_theme() - length_log(c("var1", "var2", "var3"), c("var4"), "message") %>% - expect_message("Variable lengths missing from metadata.") %>% - expect_message("lengths resolved `var1`.*`var2`.*`var3`.*`var4`") %>% - expect_message("Problem with `var1`.*`var2`.*`var3`") - }) + length_log(c("var1", "var2", "var3"), c("var4"), "message") %>% + expect_message("Variable lengths missing from metadata.") %>% + expect_message("lengths resolved `var1`.*`var2`.*`var3`.*`var4`") %>% + expect_message("Problem with `var1`.*`var2`.*`var3`") +}) ## Test 3: length_log: Missing variables messages are shown ---- -test_that("messages Test 3: length_log: Missing variables messages are shown", - { - # Remove empty lines in cli theme - local_cli_theme() +test_that("messages Test 3: length_log: Missing variables messages are shown", { + # Remove empty lines in cli theme + local_cli_theme() - label_log(c("var1", "var2", "var3"), "message") %>% - # cli messages - expect_message("Variable labels missing from metadata.") %>% - expect_message("labels skipped") %>% - # xportr_logger messages - expect_message("Problem with `var1`.*`var2`.*`var3`") - }) + label_log(c("var1", "var2", "var3"), "message") %>% + # cli messages + expect_message("Variable labels missing from metadata.") %>% + expect_message("labels skipped") %>% + # xportr_logger messages + expect_message("Problem with `var1`.*`var2`.*`var3`") +}) ## Test 4: var_names_log: Renamed variables messages are shown ---- -test_that("messages Test 4: var_names_log: Renamed variables messages are shown", - { - # Remove empty lines in cli theme - local_cli_theme() +test_that("messages Test 4: var_names_log: Renamed variables messages are shown", { + # Remove empty lines in cli theme + local_cli_theme() - tidy_names_df <- data.frame( - original_varname = c("var1", "var2", "var3", "var4", "VAR5", "VAR6"), - renamed_var = c("VAR1", "VAR2", "VAR3", "VAR4", "VAR5", "VAR6"), - col_pos = seq(1, 6), - renamed_msg = glue("renamed message {seq(1, 6)}"), - renamed_n = 0 - ) + tidy_names_df <- data.frame( + original_varname = c("var1", "var2", "var3", "var4", "VAR5", "VAR6"), + renamed_var = c("VAR1", "VAR2", "VAR3", "VAR4", "VAR5", "VAR6"), + col_pos = seq(1, 6), + renamed_msg = glue("renamed message {seq(1, 6)}"), + renamed_n = 0 + ) - tidy_names_df %>% - mutate(renamed_n = c(2, - sample( - c(0, 1, 2), - size = NROW(.data$renamed_n) - 1, - replace = TRUE - ))) %>% - 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 '.*'") %>% - expect_message("Var . : '.*' was renamed to '.*'") %>% - expect_message("Duplicate renamed term\\(s\\) were created") - }) + tidy_names_df %>% + mutate(renamed_n = c( + 2, + sample( + c(0, 1, 2), + size = NROW(.data$renamed_n) - 1, + replace = TRUE + ) + )) %>% + 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 '.*'") %>% + expect_message("Var . : '.*' was renamed to '.*'") %>% + expect_message("Duplicate renamed term\\(s\\) were created") +}) From 5e9e18922335b7843c023c89def6ffa45b4cdb55 Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Fri, 8 Mar 2024 11:33:54 -0500 Subject: [PATCH 7/9] Fixing lintr indentations issues --- DESCRIPTION | 4 +- NAMESPACE | 2 + R/xportr-package.R | 3 +- tests/testthat/test-format.R | 28 ++++---- tests/testthat/test-length.R | 19 +++--- tests/testthat/test-messages.R | 11 +-- tests/testthat/test-metadata.R | 90 +++++++++++++------------ tests/testthat/test-options.R | 4 +- tests/testthat/test-order.R | 29 ++++---- tests/testthat/test-support-for-tests.R | 8 ++- tests/testthat/test-type.R | 17 +++-- tests/testthat/test-utils-xportr.R | 30 +++++---- tests/testthat/test-write.R | 31 ++++----- 13 files changed, 148 insertions(+), 128 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 68b67ada..cdd7abf7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,13 +36,13 @@ Imports: readr, rlang (>= 0.4.10), stringr (>= 1.4.0), - tidyselect + tidyselect, + readxl Suggests: DT, knitr, labelled, metacore, - readxl, rmarkdown, testthat (>= 3.0.0), withr diff --git a/NAMESPACE b/NAMESPACE index 30a076c0..1a249eb5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -54,6 +54,7 @@ importFrom(dplyr,ungroup) importFrom(glue,glue) importFrom(glue,glue_collapse) importFrom(graphics,stem) +importFrom(haven,read_xpt) importFrom(haven,write_xpt) importFrom(lifecycle,deprecated) importFrom(magrittr,"%>%") @@ -66,6 +67,7 @@ importFrom(purrr,map_dbl) importFrom(purrr,pluck) importFrom(purrr,walk) importFrom(readr,parse_number) +importFrom(readxl,read_xlsx) importFrom(rlang,"%||%") importFrom(rlang,":=") importFrom(rlang,.data) diff --git a/R/xportr-package.R b/R/xportr-package.R index ce107099..0abc825b 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -102,7 +102,7 @@ #' @aliases xportr-package #' #' @importFrom lifecycle deprecated -#' @importFrom haven write_xpt +#' @importFrom haven write_xpt read_xpt #' @importFrom rlang abort warn inform with_options local_options .data := sym #' %||% #' @importFrom dplyr left_join bind_cols filter select rename rename_with n @@ -121,6 +121,7 @@ #' @importFrom checkmate assert assert_character assert_choice assert_data_frame #' assert_integer assert_logical assert_string makeAssertion check_data_frame #' check_r6 test_data_frame test_string vname +#' @importFrom readxl read_xlsx "_PACKAGE" globalVariables(c( diff --git a/tests/testthat/test-format.R b/tests/testthat/test-format.R index 0fc578a0..48a796bd 100644 --- a/tests/testthat/test-format.R +++ b/tests/testthat/test-format.R @@ -1,5 +1,6 @@ +# xportr_format ---- ## Test 1: xportr_format: error when metadata is not set ---- -test_that("format Test 1: xportr_format: error when metadata is not set", { +test_that("format Test 1: error when metadata is not set", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) @@ -12,7 +13,7 @@ test_that("format Test 1: xportr_format: error when metadata is not set", { }) ## Test 2: xportr_format: Gets warning when metadata has multiple rows with same variable ---- -test_that("format Test 2: xportr_format: Gets warning when metadata has multiple rows with same variable", { +test_that("format Test 2: Gets warning when metadata has multiple rows with same variable", { # This test uses the (2) functions below to reduce code duplication # All `expect_*` are being called inside the functions # @@ -23,7 +24,7 @@ test_that("format Test 2: xportr_format: Gets warning when metadata has multiple }) ## Test 3: xportr_format: Works as expected with only one domain in metadata ---- -test_that("format Test 3: xportr_format: Works as expected with only one domain in metadata", { +test_that("format Test 3: Works as expected with only one domain in metadata", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) @@ -39,7 +40,7 @@ test_that("format Test 3: xportr_format: Works as expected with only one domain }) ## Test 4: xportr_format: Variable ending in DT should produce a warning if no format ---- -test_that("format Test 4: xportr_format: Variable ending in DT should produce a warning if no format", { +test_that("format Test 4: Variable ending in DT should produce a warning if no format", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) @@ -59,7 +60,7 @@ test_that("format Test 4: xportr_format: Variable ending in DT should produce a }) ## Test 5: xportr_format: Variable ending in TM should produce an error if no format ---- -test_that("format Test 5: xportr_format: Variable ending in TM should produce an error if no format", { +test_that("format Test 5: Variable ending in TM should produce an error if no format", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHTM = c(1, 1, 2) @@ -79,7 +80,7 @@ test_that("format Test 5: xportr_format: Variable ending in TM should produce an }) ## Test 6: xportr_format: Variable ending in DTM should produce a warning if no format ---- -test_that("format Test 6: xportr_format: Variable ending in DTM should produce a warning if no format", { +test_that("format Test 6: Variable ending in DTM should produce a warning if no format", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDTM = c(1, 1, 2) @@ -121,7 +122,7 @@ test_that( ) ## Test 7: xportr_format: If a variable is character then a warning should be produced if format is > 32 in length ---- -test_that("format Test 7: xportr_format: If a variable is character then a warning should be produced if format is > 32 in length", { +test_that("format Test 7: If a variable is character then a warning should be produced if format is > 32 in length", {#nolint adsl <- data.frame( USUBJID = c("1001", "1002", "1003"), BRTHDT = c(1, 1, 2) @@ -149,27 +150,28 @@ test_that("format Test 7: xportr_format: If a variable is character then a warni }) ## Test 8: xportr_format: If a variable is numeric then an error should be produced if a format starts with `$` ---- -test_that("format Test 8: xportr_format: If a variable is numeric then an error should be produced if a format starts with `$`", { - adsl <- data.frame( +test_that( + "format Test 8: If a variable is numeric then an error should be produced if a format starts with `$`", {#nolint + adsl <- data.frame( #nolint USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) ) - metadata <- data.frame( + metadata <- data.frame( #nolint dataset = c("adsl", "adsl"), variable = c("USUBJID", "BRTHDT"), format = c("$4.", "DATE9.") ) - expect_error( + expect_error( #nolint xportr_format(adsl, metadata, verbose = "stop"), regexp = "(xportr::xportr_format) `USUBJID` is a numeric variable and should not have a `$` prefix.", fixed = TRUE ) }) -## Test 9: xportr_format: If a variable is numeric then a warning should be produced if format is > 32 in length ---- -test_that("format Test 9: xportr_format: If a variable is numeric then a warning should be produced if format is > 32 in length", { +## Test 9: xportr_format: If a variable is numeric then a warning should be produced if format is > 32 in length ---- #nolint +test_that("format Test 9: If a variable is numeric then a warning should be produced if format is > 32 in length", { #nolint adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) diff --git a/tests/testthat/test-length.R b/tests/testthat/test-length.R index f087a92a..0ffb1c9e 100644 --- a/tests/testthat/test-length.R +++ b/tests/testthat/test-length.R @@ -5,8 +5,9 @@ #' * Result of call will create SAS default length attribute (`width` for each #' variable) +# xportr_length ## Test 1: xportr_length: Accepts valid domain names in metadata object ---- -test_that("length Test 1: xportr_length: Accepts valid domain names in metadata object", { +test_that("length Test 1: Accepts valid domain names in metadata object", { adsl <- minimal_table(30) metadata <- minimal_metadata( @@ -51,7 +52,7 @@ test_that("length Test 1: xportr_length: Accepts valid domain names in metadata ## Test 2: xportr_length: CDISC data frame is being piped after another xportr function ---- test_that( - "length Test 2: xportr_length: CDISC data frame is being piped after another xportr function", + "length Test 2: CDISC data frame is being piped after another xportr function", { adsl <- minimal_table(30) metadata <- minimal_metadata( @@ -139,7 +140,7 @@ test_that("length Test 4: xportr_length: Throws message when variables not prese }) ## Test 5: xportr_length: Metacore instance can be used ---- -test_that("length Test 5: xportr_length: Metacore instance can be used", { +test_that("length Test 5: Metacore instance can be used", { skip_if_not_installed("metacore") adsl <- minimal_table(30, cols = c("x", "b")) @@ -170,7 +171,7 @@ test_that("length Test 5: xportr_length: Metacore instance can be used", { }) ## Test 6: xportr_length: Domain not in character format ---- -test_that("length Test 6: xportr_length: Domain not in character format", { +test_that("length Test 6: Domain not in character format", { skip_if_not_installed("readxl") require(haven, quietly = TRUE) @@ -185,7 +186,7 @@ test_that("length Test 6: xportr_length: Domain not in character format", { }) ## Test 7: xportr_length: error when metadata is not set ---- -test_that("length Test 7: xportr_length: error when metadata is not set", { +test_that("length Test 7: error when metadata is not set", { adsl <- minimal_table(30) expect_error(xportr_length(adsl), @@ -195,7 +196,7 @@ test_that("length Test 7: xportr_length: error when metadata is not set", { ## Test 8: xportr_length: Gets warning when metadata has multiple rows with same variable ---- test_that( - "length Test 8: xportr_length: Gets warning when metadata has multiple rows with same variable", + "length Test 8: Gets warning when metadata has multiple rows with same variable", { # This test uses the (2) functions below to reduce code duplication # All `expect_*` are being called inside the functions @@ -219,7 +220,7 @@ df <- data.frame( ) ## Test 9: xportr_length: length assigned as expected from metadata or data ---- -test_that("length Test 9: xportr_length: length assigned as expected from metadata or data", { +test_that("length Test 9: length assigned as expected from metadata or data", { result <- df %>% xportr_length(meta_example, domain = "df", length_source = "metadata") %>% expect_attr_width(c(10, 8)) @@ -232,7 +233,7 @@ test_that("length Test 9: xportr_length: length assigned as expected from metada ## Test 10: xportr_length: Gets message when length in metadata longer than data length ---- test_that( - "length Test 10: xportr_length: Gets message when length in metadata longer than data length", + "length Test 10: Gets message when length in metadata longer than data length", { result <- df %>% xportr_length(meta_example, domain = "df", length_source = "data") %>% @@ -241,7 +242,7 @@ test_that( ) ## Test 11: xportr_length: Works as expected with only one domain in metadata ---- -test_that("length Test 11: xportr_length: Works as expected with only one domain in metadata", { +test_that("length Test 11: Works as expected with only one domain in metadata", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) diff --git a/tests/testthat/test-messages.R b/tests/testthat/test-messages.R index a54b39bc..4b798ae0 100644 --- a/tests/testthat/test-messages.R +++ b/tests/testthat/test-messages.R @@ -1,7 +1,8 @@ #' Test `R/messages.R` functions +# xportr_logger ---- ## Test 1: xportr_logger: Type parameter will create correct message type ---- -test_that("messages Test 1: xportr_logger: Type parameter will create correct message type", { +test_that("messages Test 1: Type parameter will create correct message type", { xportr_logger("A message", type = "none") %>% expect_silent() @@ -19,8 +20,9 @@ test_that("messages Test 1: xportr_logger: Type parameter will create correct me expect_error("A message", class = "rlang_error") }) +# length_log ---- ## Test 2: length_log: Missing lengths messages are shown ---- -test_that("messages Test 2: length_log: Missing lengths messages are shown", { +test_that("messages Test 2: Missing lengths messages are shown", { # Remove empty lines in cli theme local_cli_theme() @@ -31,7 +33,7 @@ test_that("messages Test 2: length_log: Missing lengths messages are shown", { }) ## Test 3: length_log: Missing variables messages are shown ---- -test_that("messages Test 3: length_log: Missing variables messages are shown", { +test_that("messages Test 3: Missing variables messages are shown", { # Remove empty lines in cli theme local_cli_theme() @@ -43,8 +45,9 @@ test_that("messages Test 3: length_log: Missing variables messages are shown", { expect_message("Problem with `var1`.*`var2`.*`var3`") }) +# var_names_log ---- ## Test 4: var_names_log: Renamed variables messages are shown ---- -test_that("messages Test 4: var_names_log: Renamed variables messages are shown", { +test_that("messages Test 4: Renamed variables messages are shown", { # Remove empty lines in cli theme local_cli_theme() diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index 3baeb02a..91606ce9 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -10,8 +10,9 @@ extract_var_label <- function(.x) { vapply(.x, function(.x) attr(.x, "label"), character(1), USE.NAMES = FALSE) } +# xportr_label ---- ## Test 1: xportr_label: Correctly applies label from data.frame spec ---- -test_that("metadata Test 1: xportr_label: Correctly applies label from data.frame spec", { +test_that("metadata Test 1: Correctly applies label from data.frame spec", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "df", variable = c("x", "y"), label = c("foo", "bar")) @@ -34,7 +35,7 @@ test_that("metadata Test 1: xportr_label: Correctly applies label from data.fram }) ## Test 2: xportr_label: Correctly applies label when data is piped ---- -test_that("metadata Test 2: xportr_label: Correctly applies label when data is piped", { +test_that("metadata Test 2: Correctly applies label when data is piped", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "df", variable = c("x", "y"), label = c("foo", "bar")) @@ -56,7 +57,7 @@ test_that("metadata Test 2: xportr_label: Correctly applies label when data is p }) ## Test 3: xportr_label: Correctly applies label for custom domain ---- -test_that("metadata Test 3: xportr_label: Correctly applies label for custom domain", { +test_that("metadata Test 3: Correctly applies label for custom domain", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = rep("DOMAIN", 2), variable = c("x", "y"), label = c("foo", "bar")) @@ -78,7 +79,7 @@ test_that("metadata Test 3: xportr_label: Correctly applies label for custom dom }) ## Test 4: xportr_label: Correctly applies label from metacore spec ---- -test_that("metadata Test 4: xportr_label: Correctly applies label from metacore spec", { +test_that("metadata Test 4: Correctly applies label from metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = "a", y = "b", variable = "value") @@ -116,7 +117,7 @@ test_that("metadata Test 4: xportr_label: Correctly applies label from metacore }) ## Test 5: xportr_label: Expect error if any variable does not exist in metadata ---- -test_that("metadata Test 5: xportr_label: Expect error if any variable does not exist in metadata", { +test_that("metadata Test 5: Expect error if any variable does not exist in metadata", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -130,7 +131,7 @@ test_that("metadata Test 5: xportr_label: Expect error if any variable does not }) ## Test 6: xportr_label: Expect error if label exceeds 40 characters ---- -test_that("metadata Test 6: xportr_label: Expect error if label exceeds 40 characters", { +test_that("metadata Test 6: Expect error if label exceeds 40 characters", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -143,7 +144,7 @@ test_that("metadata Test 6: xportr_label: Expect error if label exceeds 40 chara }) ## Test 7: xportr_label: Expect error if domain is not a character ---- -test_that("metadata Test 7: xportr_label: Expect error if domain is not a character", { +test_that("metadata Test 7: Expect error if domain is not a character", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -161,8 +162,9 @@ test_that("metadata Test 7: xportr_label: Expect error if domain is not a charac ) }) +# xportr_df_label ---- ## Test 8: xportr_df_label: Correctly applies label from data.frame spec ---- -test_that("metadata Test 8: xportr_df_label: Correctly applies label from data.frame spec", { +test_that("metadata Test 8: Correctly applies label from data.frame spec", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "df", label = "Label") @@ -182,7 +184,7 @@ test_that("metadata Test 8: xportr_df_label: Correctly applies label from data.f }) ## Test 9: xportr_df_label: Correctly applies label when data is piped ---- -test_that("metadata Test 9: xportr_df_label: Correctly applies label when data is piped", { +test_that("metadata Test 9: Correctly applies label when data is piped", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "df", label = "Label") @@ -202,7 +204,7 @@ test_that("metadata Test 9: xportr_df_label: Correctly applies label when data i }) ## Test 10: xportr_df_label: Correctly applies label for custom domain ---- -test_that("metadata Test 10: xportr_df_label: Correctly applies label for custom domain", { +test_that("metadata Test 10: Correctly applies label for custom domain", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame(dataset = "DOMAIN", label = "Label") @@ -219,7 +221,7 @@ test_that("metadata Test 10: xportr_df_label: Correctly applies label for custom }) ## Test 11: xportr_df_label: Correctly applies label from metacore spec ---- -test_that("metadata Test 11: xportr_df_label: Correctly applies label from metacore spec", { +test_that("metadata Test 11: Correctly applies label from metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = "a", y = "b") @@ -248,7 +250,7 @@ test_that("metadata Test 11: xportr_df_label: Correctly applies label from metac }) ## Test 12: xportr_df_label: Expect error if label exceeds 40 characters ---- -test_that("metadata Test 12: xportr_df_label: Expect error if label exceeds 40 characters", { +test_that("metadata Test 12: Expect error if label exceeds 40 characters", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -262,7 +264,7 @@ test_that("metadata Test 12: xportr_df_label: Expect error if label exceeds 40 c }) ## Test 13: xportr_df_label: Expect error if domain is not a character ---- -test_that("metadata Test 13: xportr_df_label: Expect error if domain is not a character", { +test_that("metadata Test 13: Expect error if domain is not a character", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -279,8 +281,9 @@ test_that("metadata Test 13: xportr_df_label: Expect error if domain is not a ch ) }) +# xportr_format ---- ## Test 14: xportr_format: Set formats as expected ---- -test_that("metadata Test 14: xportr_format: Set formats as expected", { +test_that("metadata Test 14: Set formats as expected", { df <- data.frame(x = 1, y = 2) df_meta <- data.frame( dataset = "df", @@ -301,7 +304,7 @@ test_that("metadata Test 14: xportr_format: Set formats as expected", { }) ## Test 15: xportr_format: Set formats as expected when data is piped ---- -test_that("metadata Test 15: xportr_format: Set formats as expected when data is piped", { +test_that("metadata Test 15: Set formats as expected when data is piped", { df <- data.frame(x = 1, y = 2) df_meta <- data.frame( dataset = "df", @@ -322,7 +325,7 @@ test_that("metadata Test 15: xportr_format: Set formats as expected when data is }) ## Test 16: xportr_format: Set formats as expected for metacore spec ---- -test_that("metadata Test 16: xportr_format: Set formats as expected for metacore spec", { +test_that("metadata Test 16: Set formats as expected for metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = 1, y = 2) metacore_meta <- suppressMessages(suppressWarnings( @@ -351,7 +354,7 @@ test_that("metadata Test 16: xportr_format: Set formats as expected for metacore }) ## Test 17: xportr_format: Set formats as expected for custom domain ---- -test_that("metadata Test 17: xportr_format: Set formats as expected for custom domain", { +test_that("metadata Test 17: Set formats as expected for custom domain", { df <- data.frame(x = 1, y = 2) df_meta <- data.frame( dataset = "DOMAIN", @@ -372,7 +375,7 @@ test_that("metadata Test 17: xportr_format: Set formats as expected for custom d }) ## Test 18: xportr_format: Handle NA values without raising an error ---- -test_that("metadata Test 18: xportr_format: Handle NA values without raising an error", { +test_that("metadata Test 18: Handle NA values without raising an error", { df <- data.frame(x = 1, y = 2, z = 3, a = 4) df_meta <- data.frame( dataset = rep("df", 4), @@ -395,7 +398,7 @@ test_that("metadata Test 18: xportr_format: Handle NA values without raising an }) ## Test 19: xportr_format: Expect error if domain is not a character ---- -test_that("metadata Test 19: xportr_format: Expect error if domain is not a character", { +test_that("metadata Test 19: Expect error if domain is not a character", { df <- data.frame(x = 1, y = 2, z = 3, a = 4) df_meta <- data.frame( dataset = "df", @@ -413,8 +416,9 @@ test_that("metadata Test 19: xportr_format: Expect error if domain is not a char ) }) +# xportr_length ---- ## Test 20: xportr_length: Check if width attribute is set properly ---- -test_that("metadata Test 20: xportr_length: Check if width attribute is set properly", { +test_that("metadata Test 20: Check if width attribute is set properly", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -436,7 +440,7 @@ test_that("metadata Test 20: xportr_length: Check if width attribute is set prop }) ## Test 21: xportr_length: Check if width attribute is set properly when data is piped ---- -test_that("metadata Test 21: xportr_length: Check if width attribute is set properly when data is piped", { +test_that("metadata Test 21: Check if width attribute is set properly when data is piped", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = "df", @@ -458,7 +462,7 @@ test_that("metadata Test 21: xportr_length: Check if width attribute is set prop }) ## Test 22: xportr_length: Check if width attribute is set properly for metacore spec ---- -test_that("metadata Test 22: xportr_length: Check if width attribute is set properly for metacore spec", { +test_that("metadata Test 22: Check if width attribute is set properly for metacore spec", { skip_if_not_installed("metacore") df <- data.frame(x = "a", y = "b") metacore_meta <- suppressMessages(suppressWarnings( @@ -487,7 +491,7 @@ test_that("metadata Test 22: xportr_length: Check if width attribute is set prop }) ## Test 23: xportr_length: Check if width attribute is set properly when custom domain is passed ---- -test_that("metadata Test 23: xportr_length: Check if width attribute is set properly when custom domain is passed", { +test_that("metadata Test 23: Check if width attribute is set properly when custom domain is passed", { df <- data.frame(x = "a", y = "b") df_meta <- data.frame( dataset = rep("DOMAIN", 2), @@ -509,7 +513,7 @@ test_that("metadata Test 23: xportr_length: Check if width attribute is set prop }) ## Test 24: xportr_length: Expect error when a variable is not present in metadata ---- -test_that("metadata Test 24: xportr_length: Expect error when a variable is not present in metadata", { +test_that("metadata Test 24: Expect error when a variable is not present in metadata", { df <- data.frame(x = "a", y = "b", z = "c") df_meta <- data.frame( dataset = "df", @@ -525,7 +529,7 @@ test_that("metadata Test 24: xportr_length: Expect error when a variable is not }) ## Test 25: xportr_length: Check if length gets imputed when a new variable is passed ---- -test_that("metadata Test 25: xportr_length: Check if length gets imputed when a new variable is passed", { +test_that("metadata Test 25: Check if length gets imputed when a new variable is passed", { df <- data.frame(x = "a", y = "b", z = 3) df_meta <- data.frame( dataset = "df", @@ -551,7 +555,7 @@ test_that("metadata Test 25: xportr_length: Check if length gets imputed when a }) ## Test 26: xportr_length: Expect error if domain is not a character ---- -test_that("metadata Test 26: xportr_length: Expect error if domain is not a character", { +test_that("metadata Test 26: Expect error if domain is not a character", { df <- data.frame(x = "a", y = "b", z = 3) df_meta <- data.frame( dataset = "df", @@ -570,8 +574,9 @@ test_that("metadata Test 26: xportr_length: Expect error if domain is not a char ) }) +# xportr_metadata ---- ## Test 27: xportr_metadata: Impute character lengths based on class ---- -test_that("metadata Test 27: xportr_metadata: Impute character lengths based on class", { +test_that("metadata Test 27: Impute character lengths based on class", { adsl <- minimal_table(30, cols = c("x", "b")) metadata <- minimal_metadata( dataset = TRUE, length = TRUE, var_names = colnames(adsl) @@ -594,7 +599,7 @@ test_that("metadata Test 27: xportr_metadata: Impute character lengths based on }) ## Test 28: xportr_metadata: Throws message when variables not present in metadata ---- -test_that("metadata Test 28: xportr_metadata: Throws message when variables not present in metadata", { +test_that("metadata Test 28: Throws message when variables not present in metadata", { adsl <- minimal_table(30, cols = c("x", "y")) metadata <- minimal_metadata(dataset = TRUE, length = TRUE, var_names = c("x")) @@ -607,13 +612,7 @@ test_that("metadata Test 28: xportr_metadata: Throws message when variables not }) ## Test 29: xportr_metadata: Variable ordering messaging is correct ---- -test_that("metadata Test 29: xportr_metadata: Variable ordering messaging is correct", { - # skip_if_not_installed("haven") - # skip_if_not_installed("readxl") - - # require(haven, quietly = TRUE) - # require(readxl, quietly = TRUE) - +test_that("metadata Test 29: Variable ordering messaging is correct", { df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) df2 <- data.frame(a = "a", z = "z") df_meta <- data.frame( @@ -636,8 +635,9 @@ test_that("metadata Test 29: xportr_metadata: Variable ordering messaging is cor expect_message("All variables in dataset are ordered") }) +# xportr_type ---- ## Test 30: xportr_type: Variable types are coerced as expected and can raise messages ---- -test_that("metadata Test 30: xportr_type: Variable types are coerced as expected and can raise messages", { +test_that("metadata Test 30: Variable types are coerced as expected and can raise messages", { df <- data.frame( Subj = as.character(c(123, 456, 789, "", NA, NA_integer_)), Different = c("a", "b", "c", "", NA, NA_character_), @@ -664,16 +664,16 @@ test_that("metadata Test 30: xportr_type: Variable types are coerced as expected expect_message("Variable type\\(s\\) in dataframe don't match metadata") }) +# xportr_metadata ---- # many tests here are more like qualification/domain testing - this section adds # tests for `xportr_metadata()` basic functionality # start ## Test 31: xportr_metadata: Check metadata interaction with other functions ---- -test_that("metadata Test 31: xportr_metadata: Check metadata interaction with other functions", { +test_that("metadata Test 31: Check metadata interaction with other functions", { data("adsl_xportr", envir = environment()) adsl <- adsl_xportr - skip_if_not_installed("readxl") - var_spec <- readxl::read_xlsx( + var_spec <- read_xlsx( system.file("specs", "ADaM_spec.xlsx", package = "xportr"), sheet = "Variables" ) %>% @@ -743,15 +743,16 @@ test_that("metadata Test 31: xportr_metadata: Check metadata interaction with ot }) ## Test 32: xportr_metadata: must throw error if both metadata and domain are null ---- -test_that("metadata Test 32: xportr_metadata: must throw error if both metadata and domain are null", { +test_that("metadata Test 32: must throw error if both metadata and domain are null", { expect_error( xportr_metadata(data.frame(), metadata = NULL, domain = NULL), "Must provide either `metadata` or `domain` argument" ) }) +# xportr_* ---- ## Test 33: xportr_*: Domain is kept in between calls ---- -test_that("metadata Test 33: xportr_*: Domain is kept in between calls", { +test_that("metadata Test 33: Domain is kept in between calls", { # Divert all messages to tempfile, instead of printing them # note: be aware as this should only be used in tests that don't track # messages @@ -791,8 +792,9 @@ test_that("metadata Test 33: xportr_*: Domain is kept in between calls", { }) # end +# `xportr_metadata()` ---- ## Test 34: `xportr_metadata()` results match traditional results ---- -test_that("metadata Test 34: `xportr_metadata()` results match traditional results", { +test_that("metadata Test 34: results match traditional results", { data("var_spec", "dataset_spec", "adsl_xportr", envir = environment()) adsl <- adsl_xportr @@ -835,7 +837,7 @@ test_that("metadata Test 34: `xportr_metadata()` results match traditional resul ) expect_identical( - haven::read_xpt(metadata_path), - haven::read_xpt(trad_path) + read_xpt(metadata_path), + read_xpt(trad_path) ) }) diff --git a/tests/testthat/test-options.R b/tests/testthat/test-options.R index 3edc0e2b..87eff56c 100644 --- a/tests/testthat/test-options.R +++ b/tests/testthat/test-options.R @@ -1,3 +1,4 @@ +# xportr_options ---- ## Test 1: options are originally set as expected ---- test_that("options Test 1: options are originally set as expected", { op <- options() @@ -12,7 +13,6 @@ test_that("options Test 1: options are originally set as expected", { expect_equal(op$xportr.format_name, "format") }) - ## Test 2: xportr_options: options can be fetched using the xportr_options ---- test_that("options Test 2: xportr_options: options can be fetched using the xportr_options", { expect_equal(xportr_options(), xportr_options_list) @@ -28,7 +28,7 @@ test_that("options Test 2: xportr_options: options can be fetched using the xpor }) ## Test 3: xportr_options: options can be set using the xportr_options ---- -test_that("options Test 3: xportr_options: options can be set using the xportr_options", { +test_that("options Test 3: options can be set using the xportr_options", { op <- options() on.exit(options(op), add = TRUE, after = FALSE) old_name <- "old name" diff --git a/tests/testthat/test-order.R b/tests/testthat/test-order.R index 05c8cd77..2da6a78c 100644 --- a/tests/testthat/test-order.R +++ b/tests/testthat/test-order.R @@ -1,5 +1,6 @@ +# xportr_order ---- ## Test 1: xportr_order: Variable are ordered correctly for data.frame spec ---- -test_that("order Test 1: xportr_order: Variable are ordered correctly for data.frame spec", { +test_that("order Test 1: 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", @@ -13,7 +14,7 @@ test_that("order Test 1: xportr_order: Variable are ordered correctly for data.f }) ## Test 2: xportr_order: Variable are ordered correctly when data is piped ---- -test_that("order Test 2: xportr_order: Variable are ordered correctly when data is piped", { +test_that("order Test 2: 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", @@ -32,7 +33,7 @@ test_that("order Test 2: xportr_order: Variable are ordered correctly when data }) ## Test 3: xportr_order: Variable are ordered correctly for custom domain ---- -test_that("order Test 3: xportr_order: Variable are ordered correctly for custom domain", { +test_that("order Test 3: 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", @@ -48,7 +49,7 @@ test_that("order Test 3: xportr_order: Variable are ordered correctly for custom }) ## Test 4: xportr_order: Variable are ordered correctly for metacore spec ---- -test_that("order Test 4: xportr_order: Variable are ordered correctly for metacore spec", { +test_that("order Test 4: Variable are ordered correctly for metacore spec", { skip_if_not_installed("metacore") df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) @@ -79,7 +80,7 @@ test_that("order Test 4: xportr_order: Variable are ordered correctly for metaco }) ## Test 5: xportr_order: Variable are ordered when custom domain_name is passed ---- -test_that("order Test 5: xportr_order: Variable are ordered when custom domain_name is passed", { +test_that("order Test 5: 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", @@ -95,7 +96,7 @@ test_that("order Test 5: xportr_order: Variable are ordered when custom domain_n }) ## Test 6: xportr_order: Expect error if domain is not a character ---- -test_that("order Test 6: xportr_order: Expect error if domain is not a character", { +test_that("order Test 6: 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", @@ -108,7 +109,7 @@ test_that("order Test 6: xportr_order: Expect error if domain is not a character }) ## Test 7: xportr_order: error when metadata is not set ---- -test_that("order Test 7: xportr_order: error when metadata is not set", { +test_that("order Test 7: error when metadata is not set", { df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) expect_error( @@ -118,7 +119,7 @@ test_that("order Test 7: xportr_order: error when metadata is not set", { }) ## Test 8: xportr_order: Variable ordering messaging is correct ---- -test_that("order Test 8: xportr_order: Variable ordering messaging is correct", { +test_that("order Test 8: Variable ordering messaging is correct", { skip_if_not_installed("readxl") require(haven, quietly = TRUE) @@ -142,13 +143,13 @@ test_that("order Test 8: xportr_order: Variable ordering messaging is correct", ) suppressMessages(xportr_order(df2, df_meta, verbose = "message", domain = "df2") %>% - expect_message("2 variables not in spec and moved to end") %>% + expect_message("2 variables not in spec and moved to end") %>% #nolint expect_message("Variable moved to end in `.df`: `a` and `z`") %>% expect_message("All variables in dataset are ordered")) }) ## Test 9: xportr_order: Metadata order columns are coersed to numeric ---- -test_that("order Test 9: xportr_order: Metadata order columns are coersed to numeric", { +test_that("order Test 9: Metadata order columns are coersed to numeric", { df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5]) df_meta <- data.frame( dataset = "df", @@ -164,26 +165,26 @@ test_that("order Test 9: xportr_order: Metadata order columns are coersed to num }) ## Test 10: xportr_order: Gets warning when metadata has multiple rows with same variable ---- -test_that("order Test 10: xportr_order: Gets warning when metadata has multiple rows with same variable", { +test_that("order Test 10: Gets warning when metadata has multiple rows with same variable", { # This test uses the (2) functions below to reduce code duplication # All `expect_*` are being called inside the functions # # Checks that message appears when xportr.domain_name is invalid suppressMessages(multiple_vars_in_spec_helper(xportr_order) %>% - # expect_message() are being caught to provide clean test without output + # expect_message() are being caught to provide clean test without output #nolint expect_message("All variables in specification file are in dataset") %>% expect_message("All variables in dataset are ordered")) # Checks that message doesn't appear when xportr.domain_name is valid suppressMessages(multiple_vars_in_spec_helper2(xportr_order) %>% - # expect_message() are being caught to provide clean test without output + # expect_message() are being caught to provide clean test without output #nolint expect_message("All variables in specification file are in dataset") %>% expect_message("All variables in dataset are ordered")) }) ## Test 11: xportr_order: Works as expected with only one domain in metadata ---- -test_that("order Test 11: xportr_order: Works as expected with only one domain in metadata", { +test_that("order Test 11: Works as expected with only one domain in metadata", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) diff --git a/tests/testthat/test-support-for-tests.R b/tests/testthat/test-support-for-tests.R index de82baaf..918199bc 100644 --- a/tests/testthat/test-support-for-tests.R +++ b/tests/testthat/test-support-for-tests.R @@ -1,5 +1,6 @@ +# minimal_table ---- ## Test 1: minimal_table: builds minimal data frame with data ---- -test_that("support-for-tests Test 1: minimal_table: builds minimal data frame with data", { +test_that("support-for-tests Test 1: builds minimal data frame with data", { minimal_table(31) %>% NROW() %>% expect_equal(31) @@ -9,8 +10,9 @@ test_that("support-for-tests Test 1: minimal_table: builds minimal data frame wi expect_true() }) +# minimal_metadata ---- ## Test 2: minimal_metadata: builds minimal metadata data frame ---- -test_that("support-for-tests Test 2: minimal_metadata: builds minimal metadata data frame", { +test_that("support-for-tests Test 2: builds minimal metadata data frame", { sample_metadata <- minimal_metadata( dataset = TRUE, length = TRUE, @@ -26,7 +28,7 @@ test_that("support-for-tests Test 2: minimal_metadata: builds minimal metadata d }) ## Test 3: minimal_metadata: columns in minimal_table are all in metadata ---- -test_that("support-for-tests Test 3: minimal_metadata: columns in minimal_table are all in metadata", { +test_that("support-for-tests Test 3: columns in minimal_table are all in metadata", { sample_data <- minimal_table(31, cols = c("x", "y", "z", "a", "b", "c", "d")) sample_metadata <- minimal_metadata(dataset = TRUE) (colnames(sample_data) %in% sample_metadata$variable) %>% diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R index fe686b5c..fec148ec 100644 --- a/tests/testthat/test-type.R +++ b/tests/testthat/test-type.R @@ -12,6 +12,7 @@ df <- data.frame( Param = c("param1", "param2", "param3") ) +# xportr_type ---- ## Test 1: xportr_type: NAs are handled as expected ---- test_that("type Test 1: xportr_type: NAs are handled as expected", { # Namely that "" isn't converted to NA or vice versa @@ -50,7 +51,7 @@ test_that("type Test 1: xportr_type: NAs are handled as expected", { }) ## Test 2: xportr_type: Variable types are coerced as expected and can raise messages ---- -test_that("type Test 2: xportr_type: Variable types are coerced as expected and can raise messages", { +test_that("type Test 2: Variable types are coerced as expected and can raise messages", { # Remove empty lines in cli theme local_cli_theme() @@ -86,7 +87,7 @@ test_that("type Test 2: xportr_type: Variable types are coerced as expected and }) ## Test 3: xportr_type: Variables retain column attributes, besides class ---- -test_that("type Test 3: xportr_type: Variables retain column attributes, besides class", { +test_that("type Test 3: Variables retain column attributes, besides class", { adsl <- dplyr::tibble( USUBJID = c(1001, 1002, 1003), SITEID = c(001, 002, 003), @@ -132,7 +133,7 @@ test_that("type Test 3: xportr_type: Variables retain column attributes, besides }) ## Test 4: xportr_type: expect error when domain is not a character ---- -test_that("type Test 4: xportr_type: expect error when domain is not a character", { +test_that("type Test 4: expect error when domain is not a character", { df <- data.frame(x = 1, y = 2) df_meta <- data.frame( variable = c("x", "y"), @@ -170,7 +171,7 @@ test_that("type Test 5: xportr_type: works fine from metacore spec", { }) ## Test 6: xportr_type: error when metadata is not set ---- -test_that("type Test 6: xportr_type: error when metadata is not set", { +test_that("type Test 6: error when metadata is not set", { expect_error( xportr_type(df), regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" @@ -240,7 +241,7 @@ test_that("type Test 7: xportr_type: date variables are not converted to numeric }) ## Test 8: xportr_type: Gets warning when metadata has multiple rows with same variable ---- -test_that("type Test 8: xportr_type: Gets warning when metadata has multiple rows with same variable", { +test_that("type Test 8: Gets warning when metadata has multiple rows with same variable", { # This test uses the (2) functions below to reduce code duplication # All `expect_*` are being called inside the functions # @@ -288,8 +289,9 @@ metadata <- data.frame( format = c(NA, NA, "DATE9.", NA) ) +# xportr_metadata ---- ## Test 10: xportr_metadata: Var date types (--DTC) coerced as expected and raise messages ---- -test_that("type Test 10: xportr_metadata: Var date types (--DTC) coerced as expected and raise messages", { +test_that("type Test 10: Var date types (--DTC) coerced as expected and raise messages", { # Remove empty lines in cli theme local_cli_theme() @@ -306,8 +308,9 @@ test_that("type Test 10: xportr_metadata: Var date types (--DTC) coerced as expe )) }) +# xportr_type ---- ## Test 11: xportr_type: Works as expected with only one domain in metadata ---- -test_that("type Test 11: xportr_type: Works as expected with only one domain in metadata", { +test_that("type Test 11: Works as expected with only one domain in metadata", { adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) diff --git a/tests/testthat/test-utils-xportr.R b/tests/testthat/test-utils-xportr.R index 52995bb4..5f59ff57 100644 --- a/tests/testthat/test-utils-xportr.R +++ b/tests/testthat/test-utils-xportr.R @@ -24,21 +24,22 @@ test_that("utils-xportr Test 1: Get magrittr lhs side value", { ) }) - +# fmt_vars ---- ## Test 2: fmt_vars: the message returns properly formatted variables ---- -test_that("utils-xportr Test 2: fmt_vars: the message returns properly formatted variables", { +test_that("utils-xportr Test 2: 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 3: fmt_labs: the message returns properly formatted labels ---- -test_that("utils-xportr Test 3: fmt_labs: the message returns properly formatted labels", { +test_that("utils-xportr Test 3: the message returns properly formatted labels", { expect_equal(fmt_labs(4), "Label '=4'") expect_equal(fmt_labs(4:6), "Labels '=4', '=5', and '=6'") }) +# xpt_validate_var_names ---- ## Test 4: xpt_validate_var_names: Get error message when the variable is over 8 characters ---- -test_that("utils-xportr Test 4: xpt_validate_var_names: Get error message when the variable is over 8 characters", { +test_that("utils-xportr Test 4: 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." @@ -46,15 +47,15 @@ test_that("utils-xportr Test 4: xpt_validate_var_names: Get error message when t }) ## Test 5: xpt_validate_var_names: Get error message when the variable does not start with a letter ---- -test_that("utils-xportr Test 5: xpt_validate_var_names: Get error message when the variable does not start with a letter", { +test_that("utils-xportr Test 5: Get error message when the variable does not start with a letter", { #nolint expect_equal( - xpt_validate_var_names(c("FOO", "2BAR")), + xpt_validate_var_names(c("FOO", "2BAR")), #nolint "Variable `2BAR` must start with a letter." ) }) ## Test 6: xpt_validate_var_names: Get error message when the variable contains non-ASCII characters or underscore ---- -test_that("utils-xportr Test 6: xpt_validate_var_names: Get error message when the variable contains non-ASCII characters or underscore", { +test_that("utils-xportr Test 6: Get error message when the variable contains non-ASCII characters or underscore", { expect_equal( xpt_validate_var_names(c("FOO", "BAR", "FOO-BAR")), c( @@ -72,7 +73,7 @@ test_that("utils-xportr Test 6: xpt_validate_var_names: Get error message when t }) ## Test 7: xpt_validate_var_names: Get error message when tje variable contains lowercase character ---- -test_that("utils-xportr Test 7: xpt_validate_var_names: Get error message when tje variable contains lowercase character", { +test_that("utils-xportr Test 7: Get error message when the variable contains lowercase character", { xpt_validate_var_names(c("FOO", "bar")) expect_equal( xpt_validate_var_names(c("FOO", "bar")), @@ -80,8 +81,9 @@ test_that("utils-xportr Test 7: xpt_validate_var_names: Get error message when t ) }) +# xpt_validate ---- ## Test 8: xpt_validate: Get error message when the label contains over 40 characters ---- -test_that("utils-xportr Test 8: xpt_validate: Get error message when the label contains over 40 characters", { +test_that("utils-xportr Test 8: Get error message when the label contains over 40 characters", { df <- data.frame(A = 1, B = 2) long_label <- paste(rep("a", 41), collapse = "") attr(df$A, "label") <- long_label @@ -92,7 +94,7 @@ test_that("utils-xportr Test 8: xpt_validate: Get error message when the label c }) ## Test 9: xpt_validate: Doesn't error out with iso8601 format ---- -test_that("utils-xportr Test 9: xpt_validate: Doesn't error out with iso8601 format", { +test_that("utils-xportr Test 9: Doesn't error out with iso8601 format", { df <- data.frame(A = 1, B = 2) attr(df$A, "format.sas") <- "E8601LX." attr(df$B, "format.sas") <- "E8601DX20." @@ -103,7 +105,7 @@ test_that("utils-xportr Test 9: xpt_validate: Doesn't error out with iso8601 for }) ## Test 10: xpt_validate: Get error message when the label contains non-ASCII, symbol or special characters ---- -test_that("utils-xportr Test 10: xpt_validate: Get error message when the label contains non-ASCII, symbol or special characters", { +test_that("utils-xportr Test 10: 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çbar" expect_equal( @@ -113,7 +115,7 @@ test_that("utils-xportr Test 10: xpt_validate: Get error message when the label }) ## Test 11: xpt_validate: Get error message when the length of a character variable is > 200 bytes ---- -test_that("utils-xportr Test 11: xpt_validate: Get error message when the length of a character variable is > 200 bytes ", { +test_that("utils-xportr Test 11: Get error message when the length of a character variable is > 200 bytes ", { df <- data.frame(A = paste(rep("A", 201), collapse = "")) expect_equal( xpt_validate(df), @@ -122,7 +124,7 @@ test_that("utils-xportr Test 11: xpt_validate: Get error message when the length }) ## Test 12: xpt_validate: Get error message when the length of a non-ASCII character variable is > 200 bytes ---- -test_that("utils-xportr Test 12: xpt_validate: Get error message when the length of a non-ASCII character variable is > 200 bytes", { +test_that("utils-xportr Test 12: Get error message when the length of a non-ASCII character variable is > 200 bytes", { df <- data.frame(A = paste(rep("一", 67), collapse = "")) expect_equal( xpt_validate(df), @@ -131,7 +133,7 @@ test_that("utils-xportr Test 12: xpt_validate: Get error message when the length }) ## Test 13: xpt_validate: Get error message when the length of a character variable is > 200 bytes and contains NAs ---- -test_that("utils-xportr Test 13: xpt_validate: Get error message when the length of a character variable is > 200 bytes and contains NAs", { +test_that("utils-xportr Test 13: Get error message when the length of a character variable is > 200 bytes and contains NAs", { #nolint df <- data.frame(A = c(paste(rep("A", 201), collapse = ""), NA_character_)) expect_equal( xpt_validate(df), diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index af2dc0d4..aa6c45f9 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -7,8 +7,9 @@ data_to_save <- function() { # Skip large file tests unless explicitly requested test_large_files <- Sys.getenv("XPORTR.TEST_LARGE_FILES", FALSE) +# xportr_write ---- ## Test 1: xportr_write: exported data can be saved to a file ---- -test_that("write Test 1: xportr_write: exported data can be saved to a file", { +test_that("write Test 1: exported data can be saved to a file", { skip_if_not_installed("withr") tmp <- withr::local_file("xyz.xpt") local_data <- data_to_save() @@ -18,7 +19,7 @@ test_that("write Test 1: xportr_write: exported data can be saved to a file", { }) ## Test 2: xportr_write: exported data can still be saved to a file with a label ---- -test_that("write Test 2: xportr_write: exported data can still be saved to a file with a label", { +test_that("write Test 2: exported data can still be saved to a file with a label", { skip_if_not_installed("withr") tmp <- withr::local_file("xyz.xpt") @@ -33,7 +34,7 @@ test_that("write Test 2: xportr_write: exported data can still be saved to a fil }) ## Test 3: xportr_write: exported data can be saved to a file with a metadata ---- -test_that("write Test 3: xportr_write: exported data can be saved to a file with a metadata", { +test_that("write Test 3: exported data can be saved to a file with a metadata", { skip_if_not_installed("withr") tmp <- withr::local_file("xyz.xpt") @@ -50,7 +51,7 @@ test_that("write Test 3: xportr_write: exported data can be saved to a file with }) ## Test 4: xportr_write: exported data can be saved to a file with a existing metadata ---- -test_that("write Test 4: xportr_write: exported data can be saved to a file with a existing metadata", { +test_that("write Test 4: exported data can be saved to a file with a existing metadata", { skip_if_not_installed("withr") tmp <- withr::local_file("xyz.xpt") @@ -68,7 +69,7 @@ test_that("write Test 4: xportr_write: exported data can be saved to a file with }) ## Test 5: xportr_write: expect error when invalid multibyte string is passed in label ---- -test_that("write Test 5: xportr_write: expect error when invalid multibyte string is passed in label", { +test_that("write Test 5: expect error when invalid multibyte string is passed in label", { skip_if_not_installed("withr") expect_error( xportr_write( @@ -83,7 +84,7 @@ test_that("write Test 5: xportr_write: expect error when invalid multibyte strin }) ## Test 6: xportr_write: expect error when file name is over 8 characters long ---- -test_that("write Test 6: xportr_write: expect error when file name is over 8 characters long", { +test_that("write Test 6: expect error when file name is over 8 characters long", { skip_if_not_installed("withr") expect_error( xportr_write( @@ -95,7 +96,7 @@ test_that("write Test 6: xportr_write: expect error when file name is over 8 cha }) ## Test 7: xportr_write: expect error when file name contains non-ASCII symbols or special characters ---- -test_that("write Test 7: xportr_write: expect error when file name contains non-ASCII symbols or special characters", { +test_that("write Test 7: expect error when file name contains non-ASCII symbols or special characters", { skip_if_not_installed("withr") expect_error( xportr_write(data_to_save(), withr::local_file(".xpt"), strict_checks = TRUE), @@ -104,7 +105,7 @@ test_that("write Test 7: xportr_write: expect error when file name contains non- }) ## Test 8: xportr_write: expect warning when file name contains underscore and strict_checks = FALSE ---- -test_that("write Test 8: xportr_write: expect warning when file name contains underscore and strict_checks = FALSE", { +test_that("write Test 8: expect warning when file name contains underscore and strict_checks = FALSE", { skip_if_not_installed("withr") expect_warning( xportr_write(data_to_save(), withr::local_file("test_.xpt"), strict_checks = FALSE), @@ -113,7 +114,7 @@ test_that("write Test 8: xportr_write: expect warning when file name contains un }) ## Test 9: xportr_write: expect error when label contains non-ASCII symbols or special characters ---- -test_that("write Test 9: xportr_write: expect error when label contains non-ASCII symbols or special characters", { +test_that("write Test 9: expect error when label contains non-ASCII symbols or special characters", { skip_if_not_installed("withr") expect_error( xportr_write( @@ -130,7 +131,7 @@ test_that("write Test 9: xportr_write: expect error when label contains non-ASCI }) ## Test 10: xportr_write: expect error when label is over 40 characters ---- -test_that("write Test 10: xportr_write: expect error when label is over 40 characters", { +test_that("write Test 10: expect error when label is over 40 characters", { skip_if_not_installed("withr") expect_error( xportr_write( @@ -147,7 +148,7 @@ test_that("write Test 10: xportr_write: expect error when label is over 40 chara }) ## Test 11: xportr_write: expect error when an xpt validation fails with strict_checks set to TRUE ---- -test_that("write Test 11: xportr_write: expect error when an xpt validation fails with strict_checks set to TRUE", { +test_that("write Test 11: expect error when an xpt validation fails with strict_checks set to TRUE", { skip_if_not_installed("withr") local_data <- data_to_save() attr(local_data$X, "format.sas") <- "foo" @@ -168,7 +169,7 @@ test_that("write Test 11: xportr_write: expect error when an xpt validation fail }) ## Test 12: xportr_write: expect warning when an xpt validation fails with strict_checks set to FALSE ---- -test_that("write Test 12: xportr_write: expect warning when an xpt validation fails with strict_checks set to FALSE", { +test_that("write Test 12: expect warning when an xpt validation fails with strict_checks set to FALSE", { skip_if_not_installed("withr") local_data <- data_to_save() attr(local_data$X, "format.sas") <- "foo" @@ -189,7 +190,7 @@ test_that("write Test 12: xportr_write: expect warning when an xpt validation fa }) ## Test 13: xportr_write: Capture errors by haven and report them as such ---- -test_that("write Test 13: xportr_write: Capture errors by haven and report them as such", { +test_that("write Test 13: Capture errors by haven and report them as such", { skip_if_not_installed("withr") local_data <- data_to_save() attr(local_data$X, "format.sas") <- "E8601LXw.asdf" @@ -212,7 +213,7 @@ test_that("write Test 13: xportr_write: Capture errors by haven and report them }) ## Test 14: xportr_write: `split_by` attribute is used to split the data ---- -test_that("write Test 14: xportr_write: `split_by` attribute is used to split the data", { +test_that("write Test 14: `split_by` attribute is used to split the data", { tmpdir <- tempdir() tmp <- file.path(tmpdir, "xyz.xpt") @@ -256,7 +257,7 @@ test_that("write Test 14: xportr_write: `split_by` attribute is used to split th }) ## Test 15: xportr_write: Large file sizes are reported and warned ---- -test_that("write Test 15: xportr_write: Large file sizes are reported and warned", { +test_that("write Test 15: Large file sizes are reported and warned", { skip_if_not(test_large_files) tmpdir <- tempdir() tmp <- file.path(tmpdir, "xyz.xpt") From a4cfc5ae68cd8c20c0d28914a85e82c1ffd8a952 Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Fri, 8 Mar 2024 11:40:33 -0500 Subject: [PATCH 8/9] fixing Styler --- tests/testthat/test-format.R | 38 ++++++++++++++++-------------- tests/testthat/test-order.R | 2 +- tests/testthat/test-utils-xportr.R | 6 ++--- 3 files changed, 24 insertions(+), 22 deletions(-) diff --git a/tests/testthat/test-format.R b/tests/testthat/test-format.R index 48a796bd..c3e9bd09 100644 --- a/tests/testthat/test-format.R +++ b/tests/testthat/test-format.R @@ -122,7 +122,7 @@ test_that( ) ## Test 7: xportr_format: If a variable is character then a warning should be produced if format is > 32 in length ---- -test_that("format Test 7: If a variable is character then a warning should be produced if format is > 32 in length", {#nolint +test_that("format Test 7: If a variable is character then a warning should be produced if format is > 32 in length", { # nolint adsl <- data.frame( USUBJID = c("1001", "1002", "1003"), BRTHDT = c(1, 1, 2) @@ -151,27 +151,29 @@ test_that("format Test 7: If a variable is character then a warning should be pr ## Test 8: xportr_format: If a variable is numeric then an error should be produced if a format starts with `$` ---- test_that( - "format Test 8: If a variable is numeric then an error should be produced if a format starts with `$`", {#nolint - adsl <- data.frame( #nolint - USUBJID = c(1001, 1002, 1003), - BRTHDT = c(1, 1, 2) - ) + "format Test 8: If a variable is numeric then an error should be produced if a format starts with `$`", + { # nolint + adsl <- data.frame( # nolint + USUBJID = c(1001, 1002, 1003), + BRTHDT = c(1, 1, 2) + ) - metadata <- data.frame( #nolint - dataset = c("adsl", "adsl"), - variable = c("USUBJID", "BRTHDT"), - format = c("$4.", "DATE9.") - ) + metadata <- data.frame( # nolint + dataset = c("adsl", "adsl"), + variable = c("USUBJID", "BRTHDT"), + format = c("$4.", "DATE9.") + ) - expect_error( #nolint - xportr_format(adsl, metadata, verbose = "stop"), - regexp = "(xportr::xportr_format) `USUBJID` is a numeric variable and should not have a `$` prefix.", - fixed = TRUE - ) -}) + expect_error( # nolint + xportr_format(adsl, metadata, verbose = "stop"), + regexp = "(xportr::xportr_format) `USUBJID` is a numeric variable and should not have a `$` prefix.", + fixed = TRUE + ) + } +) ## Test 9: xportr_format: If a variable is numeric then a warning should be produced if format is > 32 in length ---- #nolint -test_that("format Test 9: If a variable is numeric then a warning should be produced if format is > 32 in length", { #nolint +test_that("format Test 9: If a variable is numeric then a warning should be produced if format is > 32 in length", { # nolint adsl <- data.frame( USUBJID = c(1001, 1002, 1003), BRTHDT = c(1, 1, 2) diff --git a/tests/testthat/test-order.R b/tests/testthat/test-order.R index 2da6a78c..8aaa4dc6 100644 --- a/tests/testthat/test-order.R +++ b/tests/testthat/test-order.R @@ -143,7 +143,7 @@ test_that("order Test 8: Variable ordering messaging is correct", { ) suppressMessages(xportr_order(df2, df_meta, verbose = "message", domain = "df2") %>% - expect_message("2 variables not in spec and moved to end") %>% #nolint + expect_message("2 variables not in spec and moved to end") %>% # nolint expect_message("Variable moved to end in `.df`: `a` and `z`") %>% expect_message("All variables in dataset are ordered")) }) diff --git a/tests/testthat/test-utils-xportr.R b/tests/testthat/test-utils-xportr.R index 5f59ff57..fa112d99 100644 --- a/tests/testthat/test-utils-xportr.R +++ b/tests/testthat/test-utils-xportr.R @@ -47,9 +47,9 @@ test_that("utils-xportr Test 4: Get error message when the variable is over 8 ch }) ## Test 5: xpt_validate_var_names: Get error message when the variable does not start with a letter ---- -test_that("utils-xportr Test 5: Get error message when the variable does not start with a letter", { #nolint +test_that("utils-xportr Test 5: Get error message when the variable does not start with a letter", { # nolint expect_equal( - xpt_validate_var_names(c("FOO", "2BAR")), #nolint + xpt_validate_var_names(c("FOO", "2BAR")), # nolint "Variable `2BAR` must start with a letter." ) }) @@ -133,7 +133,7 @@ test_that("utils-xportr Test 12: Get error message when the length of a non-ASCI }) ## Test 13: xpt_validate: Get error message when the length of a character variable is > 200 bytes and contains NAs ---- -test_that("utils-xportr Test 13: Get error message when the length of a character variable is > 200 bytes and contains NAs", { #nolint +test_that("utils-xportr Test 13: Get error message when the length of a character variable is > 200 bytes and contains NAs", { # nolint df <- data.frame(A = c(paste(rep("A", 201), collapse = ""), NA_character_)) expect_equal( xpt_validate(df), From d2d2e813376b7f77baca0e7ef7bd707a5e1b4bb3 Mon Sep 17 00:00:00 2001 From: sadchla-codes Date: Thu, 14 Mar 2024 10:17:59 -0400 Subject: [PATCH 9/9] Move package `readxl` to suggest --- DESCRIPTION | 4 ++-- NAMESPACE | 1 - R/xportr-package.R | 1 - tests/testthat/test-metadata.R | 2 +- 4 files changed, 3 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index cdd7abf7..68b67ada 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,13 +36,13 @@ Imports: readr, rlang (>= 0.4.10), stringr (>= 1.4.0), - tidyselect, - readxl + tidyselect Suggests: DT, knitr, labelled, metacore, + readxl, rmarkdown, testthat (>= 3.0.0), withr diff --git a/NAMESPACE b/NAMESPACE index 1a249eb5..89a75598 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,7 +67,6 @@ importFrom(purrr,map_dbl) importFrom(purrr,pluck) importFrom(purrr,walk) importFrom(readr,parse_number) -importFrom(readxl,read_xlsx) importFrom(rlang,"%||%") importFrom(rlang,":=") importFrom(rlang,.data) diff --git a/R/xportr-package.R b/R/xportr-package.R index 0abc825b..417e58b8 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -121,7 +121,6 @@ #' @importFrom checkmate assert assert_character assert_choice assert_data_frame #' assert_integer assert_logical assert_string makeAssertion check_data_frame #' check_r6 test_data_frame test_string vname -#' @importFrom readxl read_xlsx "_PACKAGE" globalVariables(c( diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index 91606ce9..49f49a6c 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -673,7 +673,7 @@ test_that("metadata Test 31: Check metadata interaction with other functions", { data("adsl_xportr", envir = environment()) adsl <- adsl_xportr - var_spec <- read_xlsx( + var_spec <- readxl::read_xlsx( system.file("specs", "ADaM_spec.xlsx", package = "xportr"), sheet = "Variables" ) %>%