From e074d2fa4c9e42eda650737b6dda071eb0d19b0c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 16:28:51 +0100 Subject: [PATCH 01/31] feat: introducing checkmate to label --- NAMESPACE | 6 ++++++ R/label.R | 15 ++++++++++++--- R/utils-xportr.R | 10 +++++----- R/xportr-package.R | 2 ++ tests/testthat/test-metadata.R | 16 ++++++++-------- 5 files changed, 33 insertions(+), 16 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 723f0e11..6e6bf6e0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,12 @@ export(xportr_write) export(xpt_validate) import(haven) import(rlang) +importFrom(checkmate,assert) +importFrom(checkmate,assert_choice) +importFrom(checkmate,assert_data_frame) +importFrom(checkmate,assert_string) +importFrom(checkmate,check_data_frame) +importFrom(checkmate,check_r6) importFrom(cli,cli_alert_danger) importFrom(cli,cli_alert_info) importFrom(cli,cli_alert_success) diff --git a/R/label.R b/R/label.R index 3d422f1b..19497d9f 100644 --- a/R/label.R +++ b/R/label.R @@ -69,6 +69,14 @@ xportr_label <- function(.df, ) metadata <- metacore } + assert( + combine = "or", + check_r6(metadata, "Metacore", null.ok = TRUE), + check_data_frame(metadata, null.ok = TRUE) + ) + assert_string(domain, null.ok = TRUE) + assert_choice(verbose, choices = .internal_verbose_choices) + domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") variable_label <- getOption("xportr.label") @@ -79,6 +87,7 @@ xportr_label <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section + assert_data_frame(.df) # deferred after `enexpr` call metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% @@ -118,10 +127,10 @@ xportr_label <- function(.df, } for (i in names(.df)) { - if (i %in% miss_vars) { - attr(.df[[i]], "label") <- "" + attr(.df[[i]], "label") <- if (i %in% miss_vars) { + "" } else { - attr(.df[[i]], "label") <- label[[i]] + label[[i]] } } diff --git a/R/utils-xportr.R b/R/utils-xportr.R index f97bb346..bb490ec5 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -310,11 +310,7 @@ xpt_validate <- function(data) { #' @return A string representing the domain #' @noRd get_domain <- function(.df, domain) { - if (!is.null(domain) && !is.character(domain)) { - abort(c("`domain` must be a vector with type .", - x = glue("Instead, it has type <{typeof(domain)}>.") - )) - } + assert_string(domain, null.ok = TRUE) result <- domain %||% attr(.df, "_xportr.df_arg_") result @@ -372,3 +368,7 @@ check_multiple_var_specs <- function(metadata, ) } } + +#' Internal choices for verbose option +#' @noRd +.internal_verbose_choices <- c("none", "warn", "message", "stop") diff --git a/R/xportr-package.R b/R/xportr-package.R index 701c4a52..e0626484 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -108,6 +108,8 @@ #' @importFrom tm stemDocument #' @importFrom graphics stem #' @importFrom magrittr %>% extract2 +#' @importFrom checkmate assert assert_string assert_choice assert_data_frame +#' check_r6 check_data_frame #' "_PACKAGE" diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index c74f906e..573f11df 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -146,11 +146,11 @@ test_that("xportr_label: Expect error if domain is not a character", { expect_error( xportr_label(df, df_meta, domain = 1), - "`domain` must be a vector with type ." + "Assertion on 'domain' failed: Must be of type 'string' \\(or 'NULL'\\), not '.*'\\." ) expect_error( xportr_label(df, df_meta, domain = NA), - "`domain` must be a vector with type ." + "Assertion on 'domain' failed: May not be NA\\." ) }) @@ -258,11 +258,11 @@ test_that("xportr_df_label: Expect error if domain is not a character", { expect_error( xportr_df_label(df, df_meta, domain = 1), - "`domain` must be a vector with type ." + "Assertion on 'domain' failed: Must be of type 'string' \\(or 'NULL'\\), not '.*'\\." ) expect_error( xportr_df_label(df, df_meta, domain = NA), - "`domain` must be a vector with type ." + "Assertion on 'domain' failed: May not be NA\\." ) }) @@ -386,11 +386,11 @@ test_that("xportr_format: Expect error if domain is not a character", { expect_error( xportr_format(df, df_meta, 1), - "`domain` must be a vector with type ." + "Assertion on 'domain' failed: Must be of type 'string' \\(or 'NULL'\\), not '.*'\\." ) expect_error( xportr_format(df, df_meta, NA), - "`domain` must be a vector with type ." + "Assertion on 'domain' failed: May not be NA\\." ) }) @@ -536,11 +536,11 @@ test_that("xportr_length: Expect error if domain is not a character", { expect_error( xportr_length(df, df_meta, 1), - "`domain` must be a vector with type ." + "Assertion on 'domain' failed: Must be of type 'string' \\(or 'NULL'\\), not '.*'\\." ) expect_error( xportr_length(df, df_meta, NA), - "`domain` must be a vector with type ." + "Assertion on 'domain' failed: May not be NA\\." ) }) From be353a6e9497e000112a55817e905acf67242192 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 16:44:16 +0100 Subject: [PATCH 02/31] feat: checkmate support in df_label --- NAMESPACE | 1 + R/df_label.R | 12 +++++++++--- R/xportr-package.R | 2 +- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 6e6bf6e0..ed9a76ca 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,6 +24,7 @@ importFrom(checkmate,assert_data_frame) importFrom(checkmate,assert_string) importFrom(checkmate,check_data_frame) importFrom(checkmate,check_r6) +importFrom(checkmate,test_string) importFrom(cli,cli_alert_danger) importFrom(cli,cli_alert_info) importFrom(cli,cli_alert_success) diff --git a/R/df_label.R b/R/df_label.R index 5009335d..5d2239e8 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -51,6 +51,13 @@ xportr_df_label <- function(.df, ) metadata <- metacore } + assert( + combine = "or", + check_r6(metadata, "Metacore", null.ok = TRUE), + check_data_frame(metadata, null.ok = TRUE) + ) + assert_string(domain, null.ok = TRUE) + domain_name <- getOption("xportr.df_domain_name") label_name <- getOption("xportr.df_label") @@ -60,6 +67,7 @@ xportr_df_label <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section + assert_data_frame(.df) # deferred after `enexpr` call ## Pull out correct metadata metadata <- metadata %||% @@ -76,9 +84,7 @@ xportr_df_label <- function(.df, # If a dataframe is used this will also be a dataframe, change to character. as.character() - label_len <- nchar(label) - - if (label_len > 40) { + if (!test_string(label, max.chars = 40)) { abort("Length of dataset label must be 40 characters or less.") } diff --git a/R/xportr-package.R b/R/xportr-package.R index e0626484..e5aa2cde 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -109,7 +109,7 @@ #' @importFrom graphics stem #' @importFrom magrittr %>% extract2 #' @importFrom checkmate assert assert_string assert_choice assert_data_frame -#' check_r6 check_data_frame +#' check_r6 check_data_frame test_string #' "_PACKAGE" From 9c0ab66fc4e593875e23801169141ac0820d3edb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 16:46:43 +0100 Subject: [PATCH 03/31] feat: checkmate support in format --- R/format.R | 10 +++++++++- R/xportr-package.R | 2 +- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/R/format.R b/R/format.R index 864faaf4..884a731c 100644 --- a/R/format.R +++ b/R/format.R @@ -53,6 +53,13 @@ xportr_format <- function(.df, ) metadata <- metacore } + assert( + combine = "or", + check_r6(metadata, "Metacore", null.ok = TRUE), + check_data_frame(metadata, null.ok = TRUE) + ) + assert_string(domain, null.ok = TRUE) + domain_name <- getOption("xportr.domain_name") format_name <- getOption("xportr.format_name") variable_name <- getOption("xportr.variable_name") @@ -63,12 +70,13 @@ xportr_format <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section + assert_data_frame(.df) # deferred after `enexpr` call metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") - if (inherits(metadata, "Metacore")) { + if (test_r6(metadata, "Metacore")) { metadata <- metadata$var_spec } diff --git a/R/xportr-package.R b/R/xportr-package.R index e5aa2cde..e239af12 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -109,7 +109,7 @@ #' @importFrom graphics stem #' @importFrom magrittr %>% extract2 #' @importFrom checkmate assert assert_string assert_choice assert_data_frame -#' check_r6 check_data_frame test_string +#' check_r6 check_data_frame test_string test_r6 #' "_PACKAGE" From 7eee7404be88086fe4977f49eaf414f7df2bc5fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 16:57:42 +0100 Subject: [PATCH 04/31] feat: checkmate support in length and messages --- NAMESPACE | 2 ++ R/length.R | 12 ++++++++++-- R/messages.R | 10 ++++++++++ R/xportr-package.R | 2 +- 4 files changed, 23 insertions(+), 3 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index ed9a76ca..eafd5ee9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,11 +19,13 @@ export(xpt_validate) import(haven) import(rlang) importFrom(checkmate,assert) +importFrom(checkmate,assert_character) importFrom(checkmate,assert_choice) importFrom(checkmate,assert_data_frame) importFrom(checkmate,assert_string) importFrom(checkmate,check_data_frame) importFrom(checkmate,check_r6) +importFrom(checkmate,test_r6) importFrom(checkmate,test_string) importFrom(cli,cli_alert_danger) importFrom(cli,cli_alert_info) diff --git a/R/length.R b/R/length.R index 81864c2b..7f925c22 100644 --- a/R/length.R +++ b/R/length.R @@ -76,6 +76,14 @@ xportr_length <- function(.df, ) metadata <- metacore } + assert( + combine = "or", + check_r6(metadata, "Metacore", null.ok = TRUE), + check_data_frame(metadata, null.ok = TRUE) + ) + assert_string(domain, null.ok = TRUE) + assert_choice(verbose, choices = .internal_verbose_choices) + domain_name <- getOption("xportr.domain_name") variable_length <- getOption("xportr.length") variable_name <- getOption("xportr.variable_name") @@ -86,12 +94,13 @@ xportr_length <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section + assert_data_frame(.df) # deferred after `enexpr` call metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") - if (inherits(metadata, "Metacore")) { + if (test_r6(metadata, "Metacore")) { metadata <- metadata$var_spec } @@ -103,7 +112,6 @@ xportr_length <- function(.df, check_multiple_var_specs(metadata, variable_name) } - # Check any variables missed in metadata but present in input data --- miss_vars <- setdiff(names(.df), metadata[[variable_name]]) diff --git a/R/messages.R b/R/messages.R index 6c4e21c0..6057491c 100644 --- a/R/messages.R +++ b/R/messages.R @@ -97,6 +97,9 @@ type_log <- function(meta_ordered, type_mismatch_ind, verbose) { #' @return Output to Console #' @export length_log <- function(miss_vars, verbose) { + assert_character(miss_vars) + assert_choice(verbose, choices = .internal_verbose_choices) + if (length(miss_vars) > 0) { cli_h2("Variable lengths missing from metadata.") cli_alert_success("{ length(miss_vars) } lengths resolved") @@ -119,6 +122,9 @@ length_log <- function(miss_vars, verbose) { #' @return Output to Console #' @export label_log <- function(miss_vars, verbose) { + assert_character(miss_vars) + assert_choice(verbose, choices = .internal_verbose_choices) + if (length(miss_vars) > 0) { cli_h2("Variable labels missing from metadata.") cli_alert_success("{ length(miss_vars) } labels skipped") @@ -141,6 +147,10 @@ label_log <- function(miss_vars, verbose) { #' @return Output to Console #' @export var_ord_msg <- function(reordered_vars, moved_vars, verbose) { + assert_character(reordered_vars) + assert_character(moved_vars) + assert_choice(verbose, choices = .internal_verbose_choices) + if (length(moved_vars) > 0) { cli_h2("{ length(moved_vars) } variables not in spec and moved to end") message <- glue( diff --git a/R/xportr-package.R b/R/xportr-package.R index e239af12..4c2a22b8 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -109,7 +109,7 @@ #' @importFrom graphics stem #' @importFrom magrittr %>% extract2 #' @importFrom checkmate assert assert_string assert_choice assert_data_frame -#' check_r6 check_data_frame test_string test_r6 +#' check_r6 check_data_frame test_string test_r6 assert_character #' "_PACKAGE" From b778b78e618c0548ec42f9d0108b349b56b38930 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 17:03:28 +0100 Subject: [PATCH 05/31] feat: checkmate support in metadata --- R/metadata.R | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/R/metadata.R b/R/metadata.R index 926de49e..e19ea05f 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -41,14 +41,22 @@ #' xportr_order() #' } xportr_metadata <- function(.df, metadata, domain = NULL) { + assert( + combine = "or", + check_r6(metadata, "Metacore", null.ok = TRUE), + check_data_frame(metadata, null.ok = TRUE) + ) + assert_string(domain, null.ok = TRUE) + ## Common section to detect domain from argument or pipes domain <- get_domain(.df, domain) if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section + assert_data_frame(.df) # deferred after `enexpr` call - structure(.df, `_xportr.df_metadata_` = metadata) + structure(.df, "_xportr.df_metadata_" = metadata) } From 68bea69a23e03db56ca963a0972d20c5327d358a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 17:16:16 +0100 Subject: [PATCH 06/31] feat: checkmate support in order --- R/order.R | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/R/order.R b/R/order.R index 43ea130d..70ffbfbf 100644 --- a/R/order.R +++ b/R/order.R @@ -72,6 +72,14 @@ xportr_order <- function(.df, ) metadata <- metacore } + assert( + combine = "or", + check_r6(metadata, "Metacore", null.ok = TRUE), + check_data_frame(metadata, null.ok = TRUE) + ) + assert_string(domain, null.ok = TRUE) + assert_choice(verbose, choices = .internal_verbose_choices) + domain_name <- getOption("xportr.domain_name") order_name <- getOption("xportr.order_name") variable_name <- getOption("xportr.variable_name") @@ -82,12 +90,13 @@ xportr_order <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section + assert_data_frame(.df) # deferred after `enexpr` call metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") - if (inherits(metadata, "Metacore")) { + if (test_r6(metadata, "Metacore")) { metadata <- metadata$ds_vars } From 7913b2166c4af6cd26025f99d08df6f83de260b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 17:26:19 +0100 Subject: [PATCH 07/31] feat: checkmate support in type --- NAMESPACE | 1 + R/messages.R | 4 ++++ R/type.R | 13 +++++++++++-- R/xportr-package.R | 2 +- 4 files changed, 17 insertions(+), 3 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index eafd5ee9..a7ac18fa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -22,6 +22,7 @@ importFrom(checkmate,assert) importFrom(checkmate,assert_character) importFrom(checkmate,assert_choice) importFrom(checkmate,assert_data_frame) +importFrom(checkmate,assert_integer) importFrom(checkmate,assert_string) importFrom(checkmate,check_data_frame) importFrom(checkmate,check_r6) diff --git a/R/messages.R b/R/messages.R index 6057491c..0c56784c 100644 --- a/R/messages.R +++ b/R/messages.R @@ -76,6 +76,10 @@ var_names_log <- function(tidy_names_df, verbose) { #' @return Output to Console #' @export type_log <- function(meta_ordered, type_mismatch_ind, verbose) { + assert_data_frame(meta_ordered) + assert_integer(type_mismatch_ind) + assert_choice(verbose, choices = .internal_verbose_choices) + if (length(type_mismatch_ind) > 0) { cli_h2("Variable type mismatches found.") cli_alert_success("{ length(type_mismatch_ind) } variables coerced") diff --git a/R/type.R b/R/type.R index c04ac317..5814e569 100644 --- a/R/type.R +++ b/R/type.R @@ -89,6 +89,14 @@ xportr_type <- function(.df, ) metadata <- metacore } + assert( + combine = "or", + check_r6(metadata, "Metacore", null.ok = TRUE), + check_data_frame(metadata, null.ok = TRUE) + ) + assert_string(domain, null.ok = TRUE) + assert_choice(verbose, choices = .internal_verbose_choices) + # Name of the columns for working with metadata domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") @@ -103,13 +111,14 @@ xportr_type <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section + assert_data_frame(.df) # deferred after `enexpr` call ## Pull out correct metadata metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") - if (inherits(metadata, "Metacore")) { + if (test_r6(metadata, "Metacore")) { metadata <- metadata$var_spec } @@ -155,7 +164,7 @@ xportr_type <- function(.df, type_log(meta_ordered, type_mismatch_ind, verbose) # Check if variable types match - is_correct <- sapply(meta_ordered[["type.x"]] == meta_ordered[["type.y"]], isTRUE) + is_correct <- vapply(meta_ordered[["type.x"]] == meta_ordered[["type.y"]], isTRUE, logical(1)) # Use the original variable iff metadata is missing that variable correct_type <- ifelse(is.na(meta_ordered[["type.y"]]), meta_ordered[["type.x"]], meta_ordered[["type.y"]]) diff --git a/R/xportr-package.R b/R/xportr-package.R index 4c2a22b8..983eb736 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -109,7 +109,7 @@ #' @importFrom graphics stem #' @importFrom magrittr %>% extract2 #' @importFrom checkmate assert assert_string assert_choice assert_data_frame -#' check_r6 check_data_frame test_string test_r6 assert_character +#' check_r6 check_data_frame test_string test_r6 assert_character assert_integer #' "_PACKAGE" From a6d565c2910e2767980155570a76c562d5817b2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 18:58:01 +0100 Subject: [PATCH 08/31] feat: checkmate support in write --- NAMESPACE | 1 + R/write.R | 15 ++++++++------- R/xportr-package.R | 1 + 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a7ac18fa..4e955824 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,7 @@ importFrom(checkmate,assert_character) importFrom(checkmate,assert_choice) importFrom(checkmate,assert_data_frame) importFrom(checkmate,assert_integer) +importFrom(checkmate,assert_logical) importFrom(checkmate,assert_string) importFrom(checkmate,check_data_frame) importFrom(checkmate,check_r6) diff --git a/R/write.R b/R/write.R index 57367fc2..930671ea 100644 --- a/R/write.R +++ b/R/write.R @@ -39,25 +39,26 @@ #' ) #' xportr_write <- function(.df, path, label = NULL, strict_checks = FALSE) { + assert_data_frame(.df) + assert_string(path) + assert_string(label, null.ok = TRUE, max.chars = 40) + assert_logical(strict_checks) + path <- normalizePath(path, mustWork = FALSE) name <- tools::file_path_sans_ext(basename(path)) if (nchar(name) > 8) { - abort("`.df` file name must be 8 characters or less.") + abort("Assertion on file name from `path` failed: Must be 8 characters or less.") } if (stringr::str_detect(name, "[^a-zA-Z0-9]")) { - abort("`.df` cannot contain any non-ASCII, symbol or underscore characters.") + abort("Assertion on file name from `path` failed: Must not contain any non-ASCII, symbol or underscore characters.") } if (!is.null(label)) { - if (nchar(label) > 40) { - abort("`label` must be 40 characters or less.") - } - if (stringr::str_detect(label, "[^[:ascii:]]")) { - abort("`label` cannot contain any non-ASCII, symbol or special characters.") + abort("Assertion on `label` failed: Must not contain any non-ASCII, symbol or special characters.") } attr(.df, "label") <- label diff --git a/R/xportr-package.R b/R/xportr-package.R index 983eb736..07bde629 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -110,6 +110,7 @@ #' @importFrom magrittr %>% extract2 #' @importFrom checkmate assert assert_string assert_choice assert_data_frame #' check_r6 check_data_frame test_string test_r6 assert_character assert_integer +#' assert_logical #' "_PACKAGE" From f50346b68d69a408878d457b23643831f3347990 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 19:24:51 +0100 Subject: [PATCH 09/31] feat: adds assertion to exported functions --- R/messages.R | 6 ++++++ R/utils-xportr.R | 2 ++ 2 files changed, 8 insertions(+) diff --git a/R/messages.R b/R/messages.R index 0c56784c..429388f8 100644 --- a/R/messages.R +++ b/R/messages.R @@ -10,6 +10,9 @@ #' @return Output to Console #' @export xportr_logger <- function(message, type = "none", ...) { + assert_character(message) + assert_choice(verbose, choices = .internal_verbose_choices) + log_fun <- switch(type, stop = abort, warn = warn, @@ -28,6 +31,9 @@ xportr_logger <- function(message, type = "none", ...) { #' @return Output to Console #' @export var_names_log <- function(tidy_names_df, verbose) { + assert_data_frame(tidy_names_df) + assert_choice(verbose, choices = .internal_verbose_choices) + only_renames <- tidy_names_df %>% filter(original_varname != renamed_var) %>% mutate( diff --git a/R/utils-xportr.R b/R/utils-xportr.R index bb490ec5..0ef807fb 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -184,6 +184,8 @@ xpt_validate_var_names <- function(varnames, #' #' @export xpt_validate <- function(data) { + assert_data_frame(data) + err_cnd <- character() # 1.0 VARIABLES ---- From d59c241215958e43c79e60ccd66111047c0b70c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 23 Nov 2023 19:34:04 +0100 Subject: [PATCH 10/31] fix: problem with xportr_logger --- DESCRIPTION | 1 + R/messages.R | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 61e81239..ed7dd83e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -47,6 +47,7 @@ Description: Tools to build CDISC compliant data sets and check for CDISC compli URL: https://github.com/atorus-research/xportr BugReports: https://github.com/atorus-research/xportr/issues Imports: + checkmate, dplyr (>= 1.0.2), purrr (>= 0.3.4), stringr (>= 1.4.0), diff --git a/R/messages.R b/R/messages.R index 429388f8..50b4df7c 100644 --- a/R/messages.R +++ b/R/messages.R @@ -11,7 +11,7 @@ #' @export xportr_logger <- function(message, type = "none", ...) { assert_character(message) - assert_choice(verbose, choices = .internal_verbose_choices) + assert_choice(type, choices = .internal_verbose_choices) log_fun <- switch(type, stop = abort, From 531f7063bb09f32a97eedebda961d108516405c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 30 Nov 2023 17:56:47 +0100 Subject: [PATCH 11/31] fix: move assert dataframe up --- R/df_label.R | 2 +- R/format.R | 2 +- R/label.R | 2 +- R/length.R | 2 +- R/metadata.R | 2 +- R/order.R | 2 +- R/type.R | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/R/df_label.R b/R/df_label.R index 5d2239e8..e5fc5545 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -51,6 +51,7 @@ xportr_df_label <- function(.df, ) metadata <- metacore } + assert_data_frame(.df) assert( combine = "or", check_r6(metadata, "Metacore", null.ok = TRUE), @@ -67,7 +68,6 @@ xportr_df_label <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section - assert_data_frame(.df) # deferred after `enexpr` call ## Pull out correct metadata metadata <- metadata %||% diff --git a/R/format.R b/R/format.R index 884a731c..8c945049 100644 --- a/R/format.R +++ b/R/format.R @@ -53,6 +53,7 @@ xportr_format <- function(.df, ) metadata <- metacore } + assert_data_frame(.df) assert( combine = "or", check_r6(metadata, "Metacore", null.ok = TRUE), @@ -70,7 +71,6 @@ xportr_format <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section - assert_data_frame(.df) # deferred after `enexpr` call metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% diff --git a/R/label.R b/R/label.R index 19497d9f..edfdba2e 100644 --- a/R/label.R +++ b/R/label.R @@ -69,6 +69,7 @@ xportr_label <- function(.df, ) metadata <- metacore } + assert_data_frame(.df) assert( combine = "or", check_r6(metadata, "Metacore", null.ok = TRUE), @@ -87,7 +88,6 @@ xportr_label <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section - assert_data_frame(.df) # deferred after `enexpr` call metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% diff --git a/R/length.R b/R/length.R index 7f925c22..21b6b152 100644 --- a/R/length.R +++ b/R/length.R @@ -76,6 +76,7 @@ xportr_length <- function(.df, ) metadata <- metacore } + assert_data_frame(.df) assert( combine = "or", check_r6(metadata, "Metacore", null.ok = TRUE), @@ -94,7 +95,6 @@ xportr_length <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section - assert_data_frame(.df) # deferred after `enexpr` call metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% diff --git a/R/metadata.R b/R/metadata.R index e19ea05f..e427eb43 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -41,6 +41,7 @@ #' xportr_order() #' } xportr_metadata <- function(.df, metadata, domain = NULL) { + assert_data_frame(.df) assert( combine = "or", check_r6(metadata, "Metacore", null.ok = TRUE), @@ -54,7 +55,6 @@ xportr_metadata <- function(.df, metadata, domain = NULL) { if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section - assert_data_frame(.df) # deferred after `enexpr` call structure(.df, "_xportr.df_metadata_" = metadata) } diff --git a/R/order.R b/R/order.R index 70ffbfbf..4a9d7915 100644 --- a/R/order.R +++ b/R/order.R @@ -72,6 +72,7 @@ xportr_order <- function(.df, ) metadata <- metacore } + assert_data_frame(.df) assert( combine = "or", check_r6(metadata, "Metacore", null.ok = TRUE), @@ -90,7 +91,6 @@ xportr_order <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section - assert_data_frame(.df) # deferred after `enexpr` call metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% diff --git a/R/type.R b/R/type.R index 5814e569..53ce1cd1 100644 --- a/R/type.R +++ b/R/type.R @@ -89,6 +89,7 @@ xportr_type <- function(.df, ) metadata <- metacore } + assert_data_frame(.df) assert( combine = "or", check_r6(metadata, "Metacore", null.ok = TRUE), @@ -111,7 +112,6 @@ xportr_type <- function(.df, if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain ## End of common section - assert_data_frame(.df) # deferred after `enexpr` call ## Pull out correct metadata metadata <- metadata %||% From 14b006ddf787e5580688224543ac8d4c450f6c7e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 30 Nov 2023 18:02:54 +0100 Subject: [PATCH 12/31] styler: remove empty space --- R/metadata.R | 1 - tests/testthat/test-pipe.R | 1 - 2 files changed, 2 deletions(-) diff --git a/R/metadata.R b/R/metadata.R index e427eb43..f1fd9701 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -69,7 +69,6 @@ xportr_metadata <- function(.df, metadata, domain = NULL) { #' #' @rdname metadata xportr_domain_name <- function(.df, domain) { - attr(.df, "_xportr.df_arg_") <- domain .df diff --git a/tests/testthat/test-pipe.R b/tests/testthat/test-pipe.R index 6f9bafb5..90876763 100644 --- a/tests/testthat/test-pipe.R +++ b/tests/testthat/test-pipe.R @@ -1,4 +1,3 @@ - test_that("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 From 9c0b997043d0536a1a132c5767dd084d00ae966d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 5 Dec 2023 17:57:17 +0100 Subject: [PATCH 13/31] feat: assert parameters on xportr_domain_name --- R/metadata.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/metadata.R b/R/metadata.R index f1fd9701..4a2a157d 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -69,6 +69,8 @@ xportr_metadata <- function(.df, metadata, domain = NULL) { #' #' @rdname metadata xportr_domain_name <- function(.df, domain) { + assert_data_frame(.df) + assert_string(domain, null.ok = TRUE) attr(.df, "_xportr.df_arg_") <- domain .df From facd4a4a767f41c9a9ece0ca632a58e158ce82aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 15 Dec 2023 11:32:04 +0100 Subject: [PATCH 14/31] docs: add news entry for this issue --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 27f14385..d746a145 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,8 @@ ## New Features and Bug Fixes +* Adds argument assertions to public functions (#175) + ## Documentation ## Deprecation and Breaking Changes From 58eba112031cb53c24d1856bc56665ff0cd11f27 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 15 Dec 2023 14:30:53 +0100 Subject: [PATCH 15/31] fix: consolidation on assertions --- NAMESPACE | 3 +++ R/df_label.R | 28 +++++++----------------- R/format.R | 27 +++++++---------------- R/label.R | 27 +++++++---------------- R/length.R | 17 ++++++++++----- R/metadata.R | 17 +++++---------- R/order.R | 27 +++++++---------------- R/type.R | 28 +++++++----------------- R/utils-xportr.R | 40 ++++++++++++++++++++++++++++++++++ R/write.R | 6 ++--- R/xportr-package.R | 7 +++--- tests/testthat/test-df_label.R | 2 +- tests/testthat/test-format.R | 2 +- tests/testthat/test-label.R | 2 +- tests/testthat/test-length.R | 2 +- tests/testthat/test-metadata.R | 1 - tests/testthat/test-order.R | 2 +- tests/testthat/test-type.R | 2 +- 18 files changed, 111 insertions(+), 129 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 4e955824..1a6419a1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,8 +27,11 @@ importFrom(checkmate,assert_logical) importFrom(checkmate,assert_string) importFrom(checkmate,check_data_frame) importFrom(checkmate,check_r6) +importFrom(checkmate,makeAssertion) +importFrom(checkmate,test_data_frame) importFrom(checkmate,test_r6) importFrom(checkmate,test_string) +importFrom(checkmate,vname) importFrom(cli,cli_alert_danger) importFrom(cli,cli_alert_info) importFrom(cli,cli_alert_success) diff --git a/R/df_label.R b/R/df_label.R index e5fc5545..912890e6 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -52,31 +52,19 @@ xportr_df_label <- function(.df, metadata <- metacore } assert_data_frame(.df) - assert( - combine = "or", - check_r6(metadata, "Metacore", null.ok = TRUE), - check_data_frame(metadata, null.ok = TRUE) - ) - assert_string(domain, null.ok = TRUE) - - domain_name <- getOption("xportr.df_domain_name") - label_name <- getOption("xportr.df_label") - ## Common section to detect domain from argument or attribute + domain <- domain %||% attr(.df, "_xportr.df_arg_") + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") - domain <- get_domain(.df, domain) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + assert_string(domain, null.ok = TRUE) + assert_metadata(metadata) - ## End of common section + if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) - ## Pull out correct metadata - metadata <- metadata %||% - attr(.df, "_xportr.df_metadata_") %||% - rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") + domain_name <- getOption("xportr.df_domain_name") + label_name <- getOption("xportr.df_label") - if (inherits(metadata, "Metacore")) { - metadata <- metadata$ds_spec - } + if (inherits(metadata, "Metacore")) metadata <- metadata$ds_spec label <- metadata %>% filter(!!sym(domain_name) == domain) %>% diff --git a/R/format.R b/R/format.R index 8c945049..cd4152aa 100644 --- a/R/format.R +++ b/R/format.R @@ -54,31 +54,20 @@ xportr_format <- function(.df, metadata <- metacore } assert_data_frame(.df) - assert( - combine = "or", - check_r6(metadata, "Metacore", null.ok = TRUE), - check_data_frame(metadata, null.ok = TRUE) - ) + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + assert_string(domain, null.ok = TRUE) + assert_metadata(metadata) + + if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) domain_name <- getOption("xportr.domain_name") format_name <- getOption("xportr.format_name") variable_name <- getOption("xportr.variable_name") - ## Common section to detect domain from argument or pipes - - domain <- get_domain(.df, domain) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - - ## End of common section - - metadata <- metadata %||% - attr(.df, "_xportr.df_metadata_") %||% - rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") - - if (test_r6(metadata, "Metacore")) { - metadata <- metadata$var_spec - } + if (test_r6(metadata, "Metacore")) metadata <- metadata$var_spec if (domain_name %in% names(metadata)) { metadata <- metadata %>% diff --git a/R/label.R b/R/label.R index edfdba2e..a856d717 100644 --- a/R/label.R +++ b/R/label.R @@ -70,32 +70,21 @@ xportr_label <- function(.df, metadata <- metacore } assert_data_frame(.df) - assert( - combine = "or", - check_r6(metadata, "Metacore", null.ok = TRUE), - check_data_frame(metadata, null.ok = TRUE) - ) + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + assert_string(domain, null.ok = TRUE) + assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) + if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") variable_label <- getOption("xportr.label") - ## Common section to detect domain from argument or pipes - - domain <- get_domain(.df, domain) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - - ## End of common section - - metadata <- metadata %||% - attr(.df, "_xportr.df_metadata_") %||% - rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") - - if (inherits(metadata, "Metacore")) { - metadata <- metadata$var_spec - } + if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec if (domain_name %in% names(metadata)) { metadata <- metadata %>% diff --git a/R/length.R b/R/length.R index 21b6b152..97890fe4 100644 --- a/R/length.R +++ b/R/length.R @@ -77,14 +77,16 @@ xportr_length <- function(.df, metadata <- metacore } assert_data_frame(.df) - assert( - combine = "or", - check_r6(metadata, "Metacore", null.ok = TRUE), - check_data_frame(metadata, null.ok = TRUE) - ) + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + assert_string(domain, null.ok = TRUE) + assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) + if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + domain_name <- getOption("xportr.domain_name") variable_length <- getOption("xportr.length") variable_name <- getOption("xportr.variable_name") @@ -98,7 +100,10 @@ xportr_length <- function(.df, metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") %||% - rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") + assert( + "Must be of type 'data.frame' or set via 'xportr_metadata()'", + .var.name = "metadata" + ) if (test_r6(metadata, "Metacore")) { metadata <- metadata$var_spec diff --git a/R/metadata.R b/R/metadata.R index 0133bfac..0f6a140a 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -42,19 +42,12 @@ #' } xportr_metadata <- function(.df, metadata, domain = NULL) { assert_data_frame(.df) - assert( - combine = "or", - check_r6(metadata, "Metacore", null.ok = TRUE), - check_data_frame(metadata, null.ok = TRUE) - ) - assert_string(domain, null.ok = TRUE) - - ## Common section to detect domain from argument or pipes - domain <- get_domain(.df, domain) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + domain <- domain %||% attr(.df, "_xportr.df_arg_") + assert_metadata(metadata, include_fun_message = FALSE) + assert_string(domain, null.ok = TRUE) - ## End of common section + if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) structure(.df, "_xportr.df_metadata_" = metadata) } @@ -72,7 +65,7 @@ xportr_metadata <- function(.df, metadata, domain = NULL) { #' @rdname metadata xportr_domain_name <- function(.df, domain) { assert_data_frame(.df) - assert_string(domain, null.ok = TRUE) + assert_string(domain) attr(.df, "_xportr.df_arg_") <- domain .df diff --git a/R/order.R b/R/order.R index 4a9d7915..31e7ccd1 100644 --- a/R/order.R +++ b/R/order.R @@ -73,32 +73,21 @@ xportr_order <- function(.df, metadata <- metacore } assert_data_frame(.df) - assert( - combine = "or", - check_r6(metadata, "Metacore", null.ok = TRUE), - check_data_frame(metadata, null.ok = TRUE) - ) + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + assert_string(domain, null.ok = TRUE) + assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) + if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + domain_name <- getOption("xportr.domain_name") order_name <- getOption("xportr.order_name") variable_name <- getOption("xportr.variable_name") - ## Common section to detect domain from argument or pipes - - domain <- get_domain(.df, domain) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - - ## End of common section - - metadata <- metadata %||% - attr(.df, "_xportr.df_metadata_") %||% - rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") - - if (test_r6(metadata, "Metacore")) { - metadata <- metadata$ds_vars - } + if (test_r6(metadata, "Metacore")) metadata <- metadata$ds_vars if (domain_name %in% names(metadata)) { metadata <- metadata %>% diff --git a/R/type.R b/R/type.R index 7b1186d1..b6ecd526 100644 --- a/R/type.R +++ b/R/type.R @@ -90,14 +90,16 @@ xportr_type <- function(.df, metadata <- metacore } assert_data_frame(.df) - assert( - combine = "or", - check_r6(metadata, "Metacore", null.ok = TRUE), - check_data_frame(metadata, null.ok = TRUE) - ) + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + assert_string(domain, null.ok = TRUE) + assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) + if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + # Name of the columns for working with metadata domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") @@ -106,21 +108,7 @@ xportr_type <- function(.df, numericTypes <- c(getOption("xportr.numeric_types"), "_numeric") format_name <- getOption("xportr.format_name") - ## Common section to detect domain from argument or pipes - - domain <- get_domain(.df, domain) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - - ## End of common section - - ## Pull out correct metadata - metadata <- metadata %||% - attr(.df, "_xportr.df_metadata_") %||% - rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`") - - if (test_r6(metadata, "Metacore")) { - metadata <- metadata$var_spec - } + if (test_r6(metadata, "Metacore")) metadata <- metadata$var_spec if (domain_name %in% names(metadata)) { metadata <- metadata %>% diff --git a/R/utils-xportr.R b/R/utils-xportr.R index 7e06c5a6..dc70a876 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -371,6 +371,46 @@ check_multiple_var_specs <- function(metadata, } } +#' Custom check for metadata object +#' +#' Improvement on the message clarity over the default assert(...) messages. +#' @noRd +#' @param metadata A data frame or `Metacore` object containing variable level +#' metadata. +check_metadata <- function(metadata, include_fun_message) { + extra_string <- ", 'Metacore' or set via 'xportr_metadata()'" + if (!include_fun_message) { + extra_string <- " or 'Metacore'" + } + + if (!test_r6(metadata, "Metacore") && !test_data_frame(metadata)) { + return( + glue( + "Must be of type 'data.frame'{extra_string},", + " not `{paste(class(metadata), collapse = '/')}" + ) + ) + } + TRUE +} + +#' Custom assertion for metadata object +#' @noRd +#' @param metadata A data frame or `Metacore` object containing variable level +#' @inheritParams checkmate::check_logical +#' metadata. +assert_metadata <- function(metadata, + include_fun_message = TRUE, + add = NULL, + .var.name = vname(metadata)) { + makeAssertion( + metadata, + check_metadata(metadata, include_fun_message), + var.name = .var.name, + collection = add + ) +} + #' Internal choices for verbose option #' @noRd .internal_verbose_choices <- c("none", "warn", "message", "stop") diff --git a/R/write.R b/R/write.R index 930671ea..05a914c6 100644 --- a/R/write.R +++ b/R/write.R @@ -49,16 +49,16 @@ xportr_write <- function(.df, path, label = NULL, strict_checks = FALSE) { name <- tools::file_path_sans_ext(basename(path)) if (nchar(name) > 8) { - abort("Assertion on file name from `path` failed: Must be 8 characters or less.") + assert("File name must be 8 characters or less.", .var.name = vname(path)) } if (stringr::str_detect(name, "[^a-zA-Z0-9]")) { - abort("Assertion on file name from `path` failed: Must not contain any non-ASCII, symbol or underscore characters.") + assert("File name must not contain any non-ASCII, symbol or underscore characters.", .var.name = vname(path)) } if (!is.null(label)) { if (stringr::str_detect(label, "[^[:ascii:]]")) { - abort("Assertion on `label` failed: Must not contain any non-ASCII, symbol or special characters.") + assert("Must not contain any non-ASCII, symbol or special characters.", .var.name = vname(label)) } attr(.df, "label") <- label diff --git a/R/xportr-package.R b/R/xportr-package.R index 07bde629..d0a129ce 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -108,10 +108,9 @@ #' @importFrom tm stemDocument #' @importFrom graphics stem #' @importFrom magrittr %>% extract2 -#' @importFrom checkmate assert assert_string assert_choice assert_data_frame -#' check_r6 check_data_frame test_string test_r6 assert_character assert_integer -#' assert_logical -#' +#' @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_r6 test_string vname "_PACKAGE" globalVariables(c( diff --git a/tests/testthat/test-df_label.R b/tests/testthat/test-df_label.R index eae3969d..2cbe1736 100644 --- a/tests/testthat/test-df_label.R +++ b/tests/testthat/test-df_label.R @@ -9,6 +9,6 @@ test_that("xportr_df_label: error when metadata is not set", { expect_error( xportr_df_label(adsl), - regexp = "Metadata must be set with `metadata` or `xportr_metadata\\(\\)`" + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" ) }) diff --git a/tests/testthat/test-format.R b/tests/testthat/test-format.R index 76b65e1d..6b39c7e6 100644 --- a/tests/testthat/test-format.R +++ b/tests/testthat/test-format.R @@ -6,7 +6,7 @@ test_that("xportr_format: error when metadata is not set", { expect_error( xportr_format(adsl), - regexp = "Metadata must be set with `metadata` or `xportr_metadata\\(\\)`" + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" ) }) diff --git a/tests/testthat/test-label.R b/tests/testthat/test-label.R index 8030a826..6d1b0349 100644 --- a/tests/testthat/test-label.R +++ b/tests/testthat/test-label.R @@ -8,7 +8,7 @@ test_that("xportr_label: error when metadata is not set", { expect_error( xportr_label(df), - regexp = "Metadata must be set with `metadata` or `xportr_metadata\\(\\)`" + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" ) }) diff --git a/tests/testthat/test-length.R b/tests/testthat/test-length.R index dd8b531f..ab4ea152 100644 --- a/tests/testthat/test-length.R +++ b/tests/testthat/test-length.R @@ -180,7 +180,7 @@ test_that("xportr_length: error when metadata is not set", { expect_error( xportr_length(adsl), - regexp = "Metadata must be set with `metadata` or `xportr_metadata\\(\\)`" + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" ) }) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index b86eb205..9f6d4169 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -548,7 +548,6 @@ test_that("xportr_length: Expect error if domain is not a character", { # tests for `xportr_metadata()` basic functionality # start test_that("xportr_metadata: Check metadata interaction with other functions", { - skip_if_not_installed("admiral") adsl <- admiral::admiral_adsl diff --git a/tests/testthat/test-order.R b/tests/testthat/test-order.R index 941a7d04..c5bde736 100644 --- a/tests/testthat/test-order.R +++ b/tests/testthat/test-order.R @@ -106,7 +106,7 @@ test_that("xportr_order: error when metadata is not set", { expect_error( xportr_order(df), - regexp = "Metadata must be set with `metadata` or `xportr_metadata\\(\\)`" + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" ) }) diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R index 2a84cf16..3a3e10d7 100644 --- a/tests/testthat/test-type.R +++ b/tests/testthat/test-type.R @@ -210,7 +210,7 @@ test_that("xportr_type: works fine from metacore spec", { test_that("xportr_type: error when metadata is not set", { expect_error( xportr_type(df), - regexp = "Metadata must be set with `metadata` or `xportr_metadata\\(\\)`" + regexp = "Must be of type 'data.frame', 'Metacore' or set via 'xportr_metadata\\(\\)'" ) }) From 5d9c36797e168224be59489a2307e01c1fce6517 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 15 Dec 2023 14:46:15 +0100 Subject: [PATCH 16/31] fix: use iwalk instead if walk2 with seq(...) --- NAMESPACE | 2 +- R/type.R | 4 ++-- R/xportr-package.R | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 1a6419a1..2c7d28c7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -62,13 +62,13 @@ importFrom(janitor,make_clean_names) importFrom(lifecycle,deprecated) importFrom(magrittr,"%>%") importFrom(magrittr,extract2) +importFrom(purrr,iwalk) importFrom(purrr,map) importFrom(purrr,map2_chr) importFrom(purrr,map_chr) importFrom(purrr,map_dbl) importFrom(purrr,pluck) importFrom(purrr,walk) -importFrom(purrr,walk2) importFrom(readr,parse_number) importFrom(stringr,str_detect) importFrom(stringr,str_extract) diff --git a/R/type.R b/R/type.R index b6ecd526..77dd74c2 100644 --- a/R/type.R +++ b/R/type.R @@ -158,8 +158,8 @@ xportr_type <- function(.df, # Walk along the columns and coerce the variables. Modifying the columns # Directly instead of something like map_dfc to preserve any attributes. - walk2( - correct_type, seq_along(correct_type), + iwalk( + correct_type, function(x, i, is_correct) { if (!is_correct[i]) { orig_attributes <- attributes(.df[[i]]) diff --git a/R/xportr-package.R b/R/xportr-package.R index d0a129ce..cbb70642 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -103,7 +103,7 @@ #' @importFrom utils capture.output str tail packageVersion #' @importFrom stringr str_detect str_extract str_replace str_replace_all #' @importFrom readr parse_number -#' @importFrom purrr map_chr map2_chr walk walk2 map map_dbl pluck +#' @importFrom purrr map_chr map2_chr walk iwalk map map_dbl pluck #' @importFrom janitor make_clean_names #' @importFrom tm stemDocument #' @importFrom graphics stem From 328c244e321d60a077aa6fc4c72379745879fa48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 15 Dec 2023 14:51:50 +0100 Subject: [PATCH 17/31] fix: change vname() in favor of string --- R/write.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/write.R b/R/write.R index 05a914c6..561ec512 100644 --- a/R/write.R +++ b/R/write.R @@ -49,16 +49,16 @@ xportr_write <- function(.df, path, label = NULL, strict_checks = FALSE) { name <- tools::file_path_sans_ext(basename(path)) if (nchar(name) > 8) { - assert("File name must be 8 characters or less.", .var.name = vname(path)) + assert("File name must be 8 characters or less.", .var.name = "path") } if (stringr::str_detect(name, "[^a-zA-Z0-9]")) { - assert("File name must not contain any non-ASCII, symbol or underscore characters.", .var.name = vname(path)) + assert("File name must not contain any non-ASCII, symbol or underscore characters.", .var.name = "path") } if (!is.null(label)) { if (stringr::str_detect(label, "[^[:ascii:]]")) { - assert("Must not contain any non-ASCII, symbol or special characters.", .var.name = vname(label)) + assert("Must not contain any non-ASCII, symbol or special characters.", .var.name = "label") } attr(.df, "label") <- label From 7428e0408ed80762d356c17d7fa0d2a20141a6fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 15 Dec 2023 14:54:44 +0100 Subject: [PATCH 18/31] fix: revert test_r6() in favor of inherits() --- NAMESPACE | 1 - R/format.R | 2 +- R/length.R | 18 +----------------- R/order.R | 2 +- R/type.R | 2 +- R/utils-xportr.R | 2 +- R/xportr-package.R | 2 +- 7 files changed, 6 insertions(+), 23 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 2c7d28c7..e07dd8b3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,7 +29,6 @@ importFrom(checkmate,check_data_frame) importFrom(checkmate,check_r6) importFrom(checkmate,makeAssertion) importFrom(checkmate,test_data_frame) -importFrom(checkmate,test_r6) importFrom(checkmate,test_string) importFrom(checkmate,vname) importFrom(cli,cli_alert_danger) diff --git a/R/format.R b/R/format.R index cd4152aa..b44c369b 100644 --- a/R/format.R +++ b/R/format.R @@ -67,7 +67,7 @@ xportr_format <- function(.df, format_name <- getOption("xportr.format_name") variable_name <- getOption("xportr.variable_name") - if (test_r6(metadata, "Metacore")) metadata <- metadata$var_spec + if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec if (domain_name %in% names(metadata)) { metadata <- metadata %>% diff --git a/R/length.R b/R/length.R index 97890fe4..16c2b07d 100644 --- a/R/length.R +++ b/R/length.R @@ -91,23 +91,7 @@ xportr_length <- function(.df, variable_length <- getOption("xportr.length") variable_name <- getOption("xportr.variable_name") - ## Common section to detect domain from argument or pipes - - domain <- get_domain(.df, domain) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - - ## End of common section - - metadata <- metadata %||% - attr(.df, "_xportr.df_metadata_") %||% - assert( - "Must be of type 'data.frame' or set via 'xportr_metadata()'", - .var.name = "metadata" - ) - - if (test_r6(metadata, "Metacore")) { - metadata <- metadata$var_spec - } + if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec if (domain_name %in% names(metadata)) { metadata <- metadata %>% diff --git a/R/order.R b/R/order.R index 31e7ccd1..442c1d10 100644 --- a/R/order.R +++ b/R/order.R @@ -87,7 +87,7 @@ xportr_order <- function(.df, order_name <- getOption("xportr.order_name") variable_name <- getOption("xportr.variable_name") - if (test_r6(metadata, "Metacore")) metadata <- metadata$ds_vars + if (inherits(metadata, "Metacore")) metadata <- metadata$ds_vars if (domain_name %in% names(metadata)) { metadata <- metadata %>% diff --git a/R/type.R b/R/type.R index 77dd74c2..bd5e0f1a 100644 --- a/R/type.R +++ b/R/type.R @@ -108,7 +108,7 @@ xportr_type <- function(.df, numericTypes <- c(getOption("xportr.numeric_types"), "_numeric") format_name <- getOption("xportr.format_name") - if (test_r6(metadata, "Metacore")) metadata <- metadata$var_spec + if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec if (domain_name %in% names(metadata)) { metadata <- metadata %>% diff --git a/R/utils-xportr.R b/R/utils-xportr.R index dc70a876..9c9edace 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -383,7 +383,7 @@ check_metadata <- function(metadata, include_fun_message) { extra_string <- " or 'Metacore'" } - if (!test_r6(metadata, "Metacore") && !test_data_frame(metadata)) { + if (!inherits(metadata, "Metacore") && !test_data_frame(metadata)) { return( glue( "Must be of type 'data.frame'{extra_string},", diff --git a/R/xportr-package.R b/R/xportr-package.R index cbb70642..54205767 100644 --- a/R/xportr-package.R +++ b/R/xportr-package.R @@ -110,7 +110,7 @@ #' @importFrom magrittr %>% extract2 #' @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_r6 test_string vname +#' check_r6 test_data_frame test_string vname "_PACKAGE" globalVariables(c( From aaf1886bbaabfa28158127e73fe17fc27b1b4136 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 15 Dec 2023 16:28:36 +0100 Subject: [PATCH 19/31] feat: change default parameter to be attribute --- R/df_label.R | 8 ++------ R/format.R | 8 ++------ R/label.R | 8 ++------ R/length.R | 8 ++------ R/metadata.R | 4 +--- R/order.R | 8 ++------ R/type.R | 8 ++------ 7 files changed, 13 insertions(+), 39 deletions(-) diff --git a/R/df_label.R b/R/df_label.R index 912890e6..d63b791f 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -40,8 +40,8 @@ #' #' adsl <- xportr_df_label(adsl, metadata, domain = "adsl") xportr_df_label <- function(.df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), metacore = deprecated()) { if (!missing(metacore)) { lifecycle::deprecate_warn( @@ -52,10 +52,6 @@ xportr_df_label <- function(.df, metadata <- metacore } assert_data_frame(.df) - - domain <- domain %||% attr(.df, "_xportr.df_arg_") - metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") - assert_string(domain, null.ok = TRUE) assert_metadata(metadata) diff --git a/R/format.R b/R/format.R index b44c369b..00fc692b 100644 --- a/R/format.R +++ b/R/format.R @@ -42,8 +42,8 @@ #' #' adsl <- xportr_format(adsl, metadata, domain = "adsl") xportr_format <- function(.df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), metacore = deprecated()) { if (!missing(metacore)) { lifecycle::deprecate_warn( @@ -54,10 +54,6 @@ xportr_format <- function(.df, metadata <- metacore } assert_data_frame(.df) - - domain <- domain %||% attr(.df, "_xportr.df_arg_") - metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") - assert_string(domain, null.ok = TRUE) assert_metadata(metadata) diff --git a/R/label.R b/R/label.R index a856d717..5667ae92 100644 --- a/R/label.R +++ b/R/label.R @@ -57,8 +57,8 @@ #' #' adsl <- xportr_label(adsl, metadata, domain = "adsl") xportr_label <- function(.df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), verbose = getOption("xportr.label_verbose", "none"), metacore = deprecated()) { if (!missing(metacore)) { @@ -70,10 +70,6 @@ xportr_label <- function(.df, metadata <- metacore } assert_data_frame(.df) - - domain <- domain %||% attr(.df, "_xportr.df_arg_") - metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") - assert_string(domain, null.ok = TRUE) assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) diff --git a/R/length.R b/R/length.R index 16c2b07d..5202345d 100644 --- a/R/length.R +++ b/R/length.R @@ -64,8 +64,8 @@ #' #' adsl <- xportr_length(adsl, metadata, domain = "adsl") xportr_length <- function(.df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), verbose = getOption("xportr.length_verbose", "none"), metacore = deprecated()) { if (!missing(metacore)) { @@ -77,10 +77,6 @@ xportr_length <- function(.df, metadata <- metacore } assert_data_frame(.df) - - domain <- domain %||% attr(.df, "_xportr.df_arg_") - metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") - assert_string(domain, null.ok = TRUE) assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) diff --git a/R/metadata.R b/R/metadata.R index 0f6a140a..6be201d7 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -40,10 +40,8 @@ #' xportr_type() %>% #' xportr_order() #' } -xportr_metadata <- function(.df, metadata, domain = NULL) { +xportr_metadata <- function(.df, metadata, domain = attr(.df, "_xportr.df_arg_")) { assert_data_frame(.df) - - domain <- domain %||% attr(.df, "_xportr.df_arg_") assert_metadata(metadata, include_fun_message = FALSE) assert_string(domain, null.ok = TRUE) diff --git a/R/order.R b/R/order.R index 442c1d10..e9cf0406 100644 --- a/R/order.R +++ b/R/order.R @@ -60,8 +60,8 @@ #' #' adsl <- xportr_order(adsl, metadata, domain = "adsl") xportr_order <- function(.df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), verbose = getOption("xportr.order_verbose", "none"), metacore = deprecated()) { if (!missing(metacore)) { @@ -73,10 +73,6 @@ xportr_order <- function(.df, metadata <- metacore } assert_data_frame(.df) - - domain <- domain %||% attr(.df, "_xportr.df_arg_") - metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") - assert_string(domain, null.ok = TRUE) assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) diff --git a/R/type.R b/R/type.R index bd5e0f1a..a54064a5 100644 --- a/R/type.R +++ b/R/type.R @@ -77,8 +77,8 @@ #' #' df2 <- xportr_type(.df, metadata, "test") xportr_type <- function(.df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), verbose = getOption("xportr.type_verbose", "none"), metacore = deprecated()) { if (!missing(metacore)) { @@ -90,10 +90,6 @@ xportr_type <- function(.df, metadata <- metacore } assert_data_frame(.df) - - domain <- domain %||% attr(.df, "_xportr.df_arg_") - metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") - assert_string(domain, null.ok = TRUE) assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) From d4511f9b0b0f571195ca288d93abe28127bfc6bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 15 Dec 2023 16:43:59 +0100 Subject: [PATCH 20/31] docs: update --- man/metadata.Rd | 2 +- man/xportr_df_label.Rd | 7 ++++++- man/xportr_format.Rd | 7 ++++++- man/xportr_label.Rd | 4 ++-- man/xportr_length.Rd | 4 ++-- man/xportr_order.Rd | 4 ++-- man/xportr_type.Rd | 4 ++-- 7 files changed, 21 insertions(+), 11 deletions(-) diff --git a/man/metadata.Rd b/man/metadata.Rd index 2a7d0af0..52b4ca6b 100644 --- a/man/metadata.Rd +++ b/man/metadata.Rd @@ -5,7 +5,7 @@ \alias{xportr_domain_name} \title{Set variable specifications and domain} \usage{ -xportr_metadata(.df, metadata, domain = NULL) +xportr_metadata(.df, metadata, domain = attr(.df, "_xportr.df_arg_")) xportr_domain_name(.df, domain) } diff --git a/man/xportr_df_label.Rd b/man/xportr_df_label.Rd index 691de990..f5d9833e 100644 --- a/man/xportr_df_label.Rd +++ b/man/xportr_df_label.Rd @@ -4,7 +4,12 @@ \alias{xportr_df_label} \title{Assign Dataset Label} \usage{ -xportr_df_label(.df, metadata = NULL, domain = NULL, metacore = deprecated()) +xportr_df_label( + .df, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), + metacore = deprecated() +) } \arguments{ \item{.df}{A data frame of CDISC standard.} diff --git a/man/xportr_format.Rd b/man/xportr_format.Rd index c6fd6e85..ad0f24b2 100644 --- a/man/xportr_format.Rd +++ b/man/xportr_format.Rd @@ -4,7 +4,12 @@ \alias{xportr_format} \title{Assign SAS Format} \usage{ -xportr_format(.df, metadata = NULL, domain = NULL, metacore = deprecated()) +xportr_format( + .df, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), + metacore = deprecated() +) } \arguments{ \item{.df}{A data frame of CDISC standard.} diff --git a/man/xportr_label.Rd b/man/xportr_label.Rd index 4cd7d18c..fc19a966 100644 --- a/man/xportr_label.Rd +++ b/man/xportr_label.Rd @@ -6,8 +6,8 @@ \usage{ xportr_label( .df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), verbose = getOption("xportr.label_verbose", "none"), metacore = deprecated() ) diff --git a/man/xportr_length.Rd b/man/xportr_length.Rd index 4c4dd224..f7674540 100644 --- a/man/xportr_length.Rd +++ b/man/xportr_length.Rd @@ -6,8 +6,8 @@ \usage{ xportr_length( .df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), verbose = getOption("xportr.length_verbose", "none"), metacore = deprecated() ) diff --git a/man/xportr_order.Rd b/man/xportr_order.Rd index 44f283cf..fbfb3213 100644 --- a/man/xportr_order.Rd +++ b/man/xportr_order.Rd @@ -6,8 +6,8 @@ \usage{ xportr_order( .df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), verbose = getOption("xportr.order_verbose", "none"), metacore = deprecated() ) diff --git a/man/xportr_type.Rd b/man/xportr_type.Rd index abfa41d8..e4b68e8c 100644 --- a/man/xportr_type.Rd +++ b/man/xportr_type.Rd @@ -6,8 +6,8 @@ \usage{ xportr_type( .df, - metadata = NULL, - domain = NULL, + metadata = attr(.df, "_xportr.df_metadata_"), + domain = attr(.df, "_xportr.df_arg_"), verbose = getOption("xportr.type_verbose", "none"), metacore = deprecated() ) From 5ab7ed508b09471a75a08cff00a4689c9e81aeb7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 19 Dec 2023 09:13:45 +0100 Subject: [PATCH 21/31] Update NEWS.md Co-authored-by: Ben Straub --- NEWS.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index d746a145..5dfd35bf 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,7 @@ ## New Features and Bug Fixes -* Adds argument assertions to public functions (#175) +* Adds argument assertions to public functions using `{checkmate}` (#175) ## Documentation From 6830ffb579ea4cb9a094deb96cc72ab254e7f480 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 17 Jan 2024 10:50:36 +0100 Subject: [PATCH 22/31] merge: revert some changes --- R/df_label.R | 2 +- R/format.R | 2 +- R/label.R | 2 +- R/length.R | 2 +- R/metadata.R | 4 ++-- R/order.R | 2 +- R/type.R | 4 ++-- R/utils-xportr.R | 8 ++++++-- tests/testthat/test-metadata.R | 2 +- 9 files changed, 16 insertions(+), 12 deletions(-) diff --git a/R/df_label.R b/R/df_label.R index 35d08318..90f25e1e 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -54,7 +54,7 @@ xportr_df_label <- function(.df, assert_string(domain, null.ok = TRUE) assert_metadata(metadata) - if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain domain_name <- getOption("xportr.df_domain_name") label_name <- getOption("xportr.df_label") diff --git a/R/format.R b/R/format.R index bf4b9ebc..34d30576 100644 --- a/R/format.R +++ b/R/format.R @@ -56,7 +56,7 @@ xportr_format <- function(.df, assert_string(domain, null.ok = TRUE) assert_metadata(metadata) - if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain domain_name <- getOption("xportr.domain_name") format_name <- getOption("xportr.format_name") diff --git a/R/label.R b/R/label.R index 158b8e90..f5b495ad 100644 --- a/R/label.R +++ b/R/label.R @@ -73,7 +73,7 @@ xportr_label <- function(.df, assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) - if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") diff --git a/R/length.R b/R/length.R index eb8c635e..b7ff15c3 100644 --- a/R/length.R +++ b/R/length.R @@ -80,7 +80,7 @@ xportr_length <- function(.df, assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) - if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain domain_name <- getOption("xportr.domain_name") variable_length <- getOption("xportr.length") diff --git a/R/metadata.R b/R/metadata.R index d19b60a8..dd6a05e8 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -47,10 +47,10 @@ xportr_metadata <- function(.df, metadata = NULL, domain = NULL) { } assert_metadata(metadata, include_fun_message = FALSE, null.ok = TRUE) assert_string(domain, null.ok = TRUE) - + ## Common section to detect domain from argument or attribute - if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain structure(.df, "_xportr.df_metadata_" = metadata) } diff --git a/R/order.R b/R/order.R index 686c8db3..bcbb0794 100644 --- a/R/order.R +++ b/R/order.R @@ -76,7 +76,7 @@ xportr_order <- function(.df, assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) - if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain domain_name <- getOption("xportr.domain_name") order_name <- getOption("xportr.order_name") diff --git a/R/type.R b/R/type.R index b7943c0f..342a5840 100644 --- a/R/type.R +++ b/R/type.R @@ -90,10 +90,10 @@ xportr_type <- function(.df, } assert_data_frame(.df) assert_string(domain, null.ok = TRUE) - assert_metadata(metadata) + assert_metadata(metadata, null.ok = TRUE) assert_choice(verbose, choices = .internal_verbose_choices) - if (!is.null(domain)) .df <- xportr_domain_name(.df, domain) + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain # Name of the columns for working with metadata domain_name <- getOption("xportr.domain_name") diff --git a/R/utils-xportr.R b/R/utils-xportr.R index b59c1d78..a5ccea2a 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -388,8 +388,11 @@ check_multiple_var_specs <- function(metadata, #' Improvement on the message clarity over the default assert(...) messages. #' @noRd #' @param metadata A data frame or `Metacore` object containing variable level +#' @inheritParams checkmate::check_logical #' metadata. -check_metadata <- function(metadata, include_fun_message) { +check_metadata <- function(metadata, include_fun_message, null.ok = FALSE) { + if (is.null(metadata) && null.ok) return(TRUE) + extra_string <- ", 'Metacore' or set via 'xportr_metadata()'" if (!include_fun_message) { extra_string <- " or 'Metacore'" @@ -413,11 +416,12 @@ check_metadata <- function(metadata, include_fun_message) { #' metadata. assert_metadata <- function(metadata, include_fun_message = TRUE, + null.ok = FALSE, add = NULL, .var.name = vname(metadata)) { makeAssertion( metadata, - check_metadata(metadata, include_fun_message), + check_metadata(metadata, include_fun_message, null.ok), var.name = .var.name, collection = add ) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index e10ce09e..1ebf4e97 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -610,7 +610,7 @@ test_that("xportr_metadata: Check metadata interaction with other functions", { test_that("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" + "Must provide either `metadata` or `domain` argument" ) }) From fb1aa2b9799f30d4c59cec9f6d26e6dbc8bab5c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 17 Jan 2024 10:58:25 +0100 Subject: [PATCH 23/31] minor bugfixes --- R/type.R | 2 +- R/write.R | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/type.R b/R/type.R index 342a5840..075328f0 100644 --- a/R/type.R +++ b/R/type.R @@ -90,7 +90,7 @@ xportr_type <- function(.df, } assert_data_frame(.df) assert_string(domain, null.ok = TRUE) - assert_metadata(metadata, null.ok = TRUE) + assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain diff --git a/R/write.R b/R/write.R index eab886d4..96281945 100644 --- a/R/write.R +++ b/R/write.R @@ -50,9 +50,8 @@ xportr_write <- function(.df, label = deprecated()) { assert_data_frame(.df) assert_string(path) - assert_metadata(metadata) + assert_metadata(metadata, null.ok = TRUE) assert_logical(strict_checks) - assert_string(label, null.ok = TRUE, max.chars = 40) path <- normalizePath(path, mustWork = FALSE) @@ -71,6 +70,7 @@ xportr_write <- function(.df, what = "xportr_write(label = )", with = "xportr_write(metadata = )" ) + assert_string(label, null.ok = TRUE, max.chars = 40) metadata <- data.frame(dataset = domain, label = label) } if (!is.null(metadata)) { @@ -80,9 +80,9 @@ xportr_write <- function(.df, if (nchar(name) > 8) { assert(".df file name must be 8 characters or less.", .var.name = "path") } - + checks <- xpt_validate(.df) - + if (stringr::str_detect(name, "[^a-zA-Z0-9]")) { checks <- c(checks, "`.df` cannot contain any non-ASCII, symbol or underscore characters.") } From 8aa98d0161f397383ab52a7af7c4d03831d657c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 17 Jan 2024 11:01:47 +0100 Subject: [PATCH 24/31] default value for domain is attribute --- R/write.R | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/R/write.R b/R/write.R index 96281945..6b667af3 100644 --- a/R/write.R +++ b/R/write.R @@ -45,7 +45,7 @@ xportr_write <- function(.df, path, metadata = NULL, - domain = NULL, + domain = attr(.df, "_xportr.df_arg_"), strict_checks = FALSE, label = deprecated()) { assert_data_frame(.df) @@ -53,17 +53,12 @@ xportr_write <- function(.df, assert_metadata(metadata, null.ok = TRUE) assert_logical(strict_checks) + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + path <- normalizePath(path, mustWork = FALSE) name <- tools::file_path_sans_ext(basename(path)) - ## Common section to detect domain from argument or attribute - - domain <- get_domain(.df, domain) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - - ## End of common section - if (!missing(label)) { lifecycle::deprecate_warn( when = "0.3.2", From 33cb7c87c898018284c7c6d6a9854847694ff49a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 17 Jan 2024 11:03:54 +0100 Subject: [PATCH 25/31] tests: use strict checks to get ascii error --- tests/testthat/test-write.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index d53c7eb0..31837977 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -96,7 +96,7 @@ test_that("xportr_write: expect error when file name contains non-ASCII symbols on.exit(unlink(tmpdir)) - expect_error(xportr_write(data_to_save, tmp)) + expect_error(xportr_write(data_to_save, tmp, strict_checks = TRUE)) }) test_that("xportr_write: expect warning when file name contains underscore and strict_checks = FALSE", { From 810f3b0612b9b1e492685eb0545b56a33d02b9af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 17 Jan 2024 11:09:49 +0100 Subject: [PATCH 26/31] docs: update documentation and removes unused function --- R/utils-xportr.R | 11 ----------- man/xportr_write.Rd | 2 +- 2 files changed, 1 insertion(+), 12 deletions(-) diff --git a/R/utils-xportr.R b/R/utils-xportr.R index a5ccea2a..d1959222 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -319,17 +319,6 @@ xpt_validate <- function(data) { return(err_cnd) } -#' Get the domain from argument or from the existing domain attr -#' -#' @return A string representing the domain -#' @noRd -get_domain <- function(.df, domain) { - assert_string(domain, null.ok = TRUE) - - result <- domain %||% attr(.df, "_xportr.df_arg_") - result -} - #' Get Origin Object of a Series of Pipes #' #' @return The R Object at the top of a pipe stack diff --git a/man/xportr_write.Rd b/man/xportr_write.Rd index 31c91c1e..9c8a134c 100644 --- a/man/xportr_write.Rd +++ b/man/xportr_write.Rd @@ -8,7 +8,7 @@ xportr_write( .df, path, metadata = NULL, - domain = NULL, + domain = attr(.df, "_xportr.df_arg_"), strict_checks = FALSE, label = deprecated() ) From 3f6ea8d3d92e3dae1637d0be6ae52930d36cde17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 17 Jan 2024 11:19:19 +0100 Subject: [PATCH 27/31] style: missing styler --- R/utils-xportr.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/utils-xportr.R b/R/utils-xportr.R index d1959222..19086b4c 100644 --- a/R/utils-xportr.R +++ b/R/utils-xportr.R @@ -380,7 +380,9 @@ check_multiple_var_specs <- function(metadata, #' @inheritParams checkmate::check_logical #' metadata. check_metadata <- function(metadata, include_fun_message, null.ok = FALSE) { - if (is.null(metadata) && null.ok) return(TRUE) + if (is.null(metadata) && null.ok) { + return(TRUE) + } extra_string <- ", 'Metacore' or set via 'xportr_metadata()'" if (!include_fun_message) { From a7d6775fd6079b58ad48d9b876a6bf1c092a16d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 22 Jan 2024 23:03:54 +0100 Subject: [PATCH 28/31] revert: default arguments take NULL --- R/df_label.R | 16 ++++++++++++---- R/format.R | 16 ++++++++++++---- R/label.R | 16 ++++++++++++---- R/length.R | 16 ++++++++++++---- R/metadata.R | 18 +++++++++++++----- R/order.R | 16 ++++++++++++---- R/type.R | 16 ++++++++++++---- R/write.R | 11 ++++++++--- man/xportr_df_label.Rd | 7 +------ man/xportr_format.Rd | 7 +------ man/xportr_label.Rd | 4 ++-- man/xportr_length.Rd | 4 ++-- man/xportr_order.Rd | 4 ++-- man/xportr_type.Rd | 4 ++-- man/xportr_write.Rd | 2 +- 15 files changed, 104 insertions(+), 53 deletions(-) diff --git a/R/df_label.R b/R/df_label.R index 90f25e1e..6891d7c6 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -40,8 +40,8 @@ #' #' adsl <- xportr_df_label(adsl, metadata, domain = "adsl") xportr_df_label <- function(.df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, metacore = deprecated()) { if (!missing(metacore)) { lifecycle::deprecate_stop( @@ -50,12 +50,20 @@ xportr_df_label <- function(.df, with = "xportr_df_label(metadata = )" ) } + + ## Common section to detect default attributes + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + + ## End of common section + assert_data_frame(.df) assert_string(domain, null.ok = TRUE) assert_metadata(metadata) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - domain_name <- getOption("xportr.df_domain_name") label_name <- getOption("xportr.df_label") diff --git a/R/format.R b/R/format.R index 3033e09b..7a92acc5 100644 --- a/R/format.R +++ b/R/format.R @@ -42,8 +42,8 @@ #' #' adsl <- xportr_format(adsl, metadata, domain = "adsl") xportr_format <- function(.df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, metacore = deprecated()) { if (!missing(metacore)) { lifecycle::deprecate_stop( @@ -52,12 +52,20 @@ xportr_format <- function(.df, with = "xportr_format(metadata = )" ) } + + ## Common section to detect default attributes + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + + ## End of common section + assert_data_frame(.df) assert_string(domain, null.ok = TRUE) assert_metadata(metadata) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - domain_name <- getOption("xportr.domain_name") format_name <- getOption("xportr.format_name") variable_name <- getOption("xportr.variable_name") diff --git a/R/label.R b/R/label.R index f5b495ad..5df997e0 100644 --- a/R/label.R +++ b/R/label.R @@ -57,8 +57,8 @@ #' #' adsl <- xportr_label(adsl, metadata, domain = "adsl") xportr_label <- function(.df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, verbose = getOption("xportr.label_verbose", "none"), metacore = deprecated()) { if (!missing(metacore)) { @@ -68,13 +68,21 @@ xportr_label <- function(.df, with = "xportr_label(metadata = )" ) } + + ## Common section to detect default attributes + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + + ## End of common section + assert_data_frame(.df) assert_string(domain, null.ok = TRUE) assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") variable_label <- getOption("xportr.label") diff --git a/R/length.R b/R/length.R index b7ff15c3..76314cd7 100644 --- a/R/length.R +++ b/R/length.R @@ -64,8 +64,8 @@ #' #' adsl <- xportr_length(adsl, metadata, domain = "adsl") xportr_length <- function(.df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, verbose = getOption("xportr.length_verbose", "none"), metacore = deprecated()) { if (!missing(metacore)) { @@ -75,13 +75,21 @@ xportr_length <- function(.df, with = "xportr_length(metadata = )" ) } + + ## Common section to detect default attributes + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + + ## End of common section + assert_data_frame(.df) assert_string(domain, null.ok = TRUE) assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - domain_name <- getOption("xportr.domain_name") variable_length <- getOption("xportr.length") variable_name <- getOption("xportr.variable_name") diff --git a/R/metadata.R b/R/metadata.R index dd6a05e8..0fda0c42 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -41,16 +41,24 @@ #' xportr_order() #' } xportr_metadata <- function(.df, metadata = NULL, domain = NULL) { - assert_data_frame(.df) + if (is.null(metadata) && is.null(domain)) { stop("Assertion failed on `metadata` and `domain`: Must provide either `metadata` or `domain` argument") } - assert_metadata(metadata, include_fun_message = FALSE, null.ok = TRUE) - assert_string(domain, null.ok = TRUE) - ## Common section to detect domain from argument or attribute + ## Common section to detect default attributes + domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - structure(.df, "_xportr.df_metadata_" = metadata) + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + if (!is.null(metadata)) attr(.df, "_xportr.df_metadata_") <- metadata + + ## End of common section + + assert_data_frame(.df) + assert_metadata(metadata, include_fun_message = FALSE, null.ok = TRUE) + assert_string(domain, null.ok = TRUE) + + .df } diff --git a/R/order.R b/R/order.R index 02b9e259..fac37ccc 100644 --- a/R/order.R +++ b/R/order.R @@ -60,8 +60,8 @@ #' #' adsl <- xportr_order(adsl, metadata, domain = "adsl") xportr_order <- function(.df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, verbose = getOption("xportr.order_verbose", "none"), metacore = deprecated()) { if (!missing(metacore)) { @@ -71,13 +71,21 @@ xportr_order <- function(.df, with = "xportr_order(metadata = )" ) } + + ## Common section to detect default attributes + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + + ## End of common section + assert_data_frame(.df) assert_string(domain, null.ok = TRUE) assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - domain_name <- getOption("xportr.domain_name") order_name <- getOption("xportr.order_name") variable_name <- getOption("xportr.variable_name") diff --git a/R/type.R b/R/type.R index 90cd43ac..16ca8518 100644 --- a/R/type.R +++ b/R/type.R @@ -78,8 +78,8 @@ #' #' df2 <- xportr_type(.df, metadata, "test") xportr_type <- function(.df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, verbose = getOption("xportr.type_verbose", "none"), metacore = deprecated()) { if (!missing(metacore)) { @@ -89,13 +89,21 @@ xportr_type <- function(.df, with = "xportr_type(metadata = )" ) } + + ## Common section to detect default attributes + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + + ## End of common section + assert_data_frame(.df) assert_string(domain, null.ok = TRUE) assert_metadata(metadata) assert_choice(verbose, choices = .internal_verbose_choices) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - # Name of the columns for working with metadata domain_name <- getOption("xportr.domain_name") variable_name <- getOption("xportr.variable_name") diff --git a/R/write.R b/R/write.R index 0463eada..3cd7e65d 100644 --- a/R/write.R +++ b/R/write.R @@ -49,16 +49,21 @@ xportr_write <- function(.df, path, metadata = NULL, - domain = attr(.df, "_xportr.df_arg_"), + domain = NULL, strict_checks = FALSE, label = deprecated()) { + ## Common section to detect default attributes + + domain <- domain %||% attr(.df, "_xportr.df_arg_") + if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + + ## End of common section + assert_data_frame(.df) assert_string(path) assert_metadata(metadata, null.ok = TRUE) assert_logical(strict_checks) - if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - path <- normalizePath(path, mustWork = FALSE) name <- tools::file_path_sans_ext(basename(path)) diff --git a/man/xportr_df_label.Rd b/man/xportr_df_label.Rd index 7285571b..363c59c4 100644 --- a/man/xportr_df_label.Rd +++ b/man/xportr_df_label.Rd @@ -4,12 +4,7 @@ \alias{xportr_df_label} \title{Assign Dataset Label} \usage{ -xportr_df_label( - .df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), - metacore = deprecated() -) +xportr_df_label(.df, metadata = NULL, domain = NULL, metacore = deprecated()) } \arguments{ \item{.df}{A data frame of CDISC standard.} diff --git a/man/xportr_format.Rd b/man/xportr_format.Rd index 5556439b..dd883554 100644 --- a/man/xportr_format.Rd +++ b/man/xportr_format.Rd @@ -4,12 +4,7 @@ \alias{xportr_format} \title{Assign SAS Format} \usage{ -xportr_format( - .df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), - metacore = deprecated() -) +xportr_format(.df, metadata = NULL, domain = NULL, metacore = deprecated()) } \arguments{ \item{.df}{A data frame of CDISC standard.} diff --git a/man/xportr_label.Rd b/man/xportr_label.Rd index 881d646f..6af7ad9a 100644 --- a/man/xportr_label.Rd +++ b/man/xportr_label.Rd @@ -6,8 +6,8 @@ \usage{ xportr_label( .df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, verbose = getOption("xportr.label_verbose", "none"), metacore = deprecated() ) diff --git a/man/xportr_length.Rd b/man/xportr_length.Rd index ceecd8d0..b7f3e818 100644 --- a/man/xportr_length.Rd +++ b/man/xportr_length.Rd @@ -6,8 +6,8 @@ \usage{ xportr_length( .df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, verbose = getOption("xportr.length_verbose", "none"), metacore = deprecated() ) diff --git a/man/xportr_order.Rd b/man/xportr_order.Rd index 97de8fa2..50fd7e73 100644 --- a/man/xportr_order.Rd +++ b/man/xportr_order.Rd @@ -6,8 +6,8 @@ \usage{ xportr_order( .df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, verbose = getOption("xportr.order_verbose", "none"), metacore = deprecated() ) diff --git a/man/xportr_type.Rd b/man/xportr_type.Rd index 4a79b9da..f8c17945 100644 --- a/man/xportr_type.Rd +++ b/man/xportr_type.Rd @@ -6,8 +6,8 @@ \usage{ xportr_type( .df, - metadata = attr(.df, "_xportr.df_metadata_"), - domain = attr(.df, "_xportr.df_arg_"), + metadata = NULL, + domain = NULL, verbose = getOption("xportr.type_verbose", "none"), metacore = deprecated() ) diff --git a/man/xportr_write.Rd b/man/xportr_write.Rd index cea85a83..b85f1766 100644 --- a/man/xportr_write.Rd +++ b/man/xportr_write.Rd @@ -8,7 +8,7 @@ xportr_write( .df, path, metadata = NULL, - domain = attr(.df, "_xportr.df_arg_"), + domain = NULL, strict_checks = FALSE, label = deprecated() ) From e3b35d6c66c90629746363bfa9373180a8d91304 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 22 Jan 2024 23:13:14 +0100 Subject: [PATCH 29/31] docs: rename comment and move lifecycle check to top --- R/df_label.R | 2 +- R/format.R | 2 +- R/label.R | 2 +- R/length.R | 2 +- R/metadata.R | 2 +- R/order.R | 2 +- R/type.R | 2 +- R/write.R | 23 +++++++++++++---------- 8 files changed, 20 insertions(+), 17 deletions(-) diff --git a/R/df_label.R b/R/df_label.R index 6891d7c6..81a115ec 100644 --- a/R/df_label.R +++ b/R/df_label.R @@ -51,7 +51,7 @@ xportr_df_label <- function(.df, ) } - ## Common section to detect default attributes + ## Common section to detect default arguments domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain diff --git a/R/format.R b/R/format.R index 7a92acc5..775e0e60 100644 --- a/R/format.R +++ b/R/format.R @@ -53,7 +53,7 @@ xportr_format <- function(.df, ) } - ## Common section to detect default attributes + ## Common section to detect default arguments domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain diff --git a/R/label.R b/R/label.R index 5df997e0..f570bc56 100644 --- a/R/label.R +++ b/R/label.R @@ -69,7 +69,7 @@ xportr_label <- function(.df, ) } - ## Common section to detect default attributes + ## Common section to detect default arguments domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain diff --git a/R/length.R b/R/length.R index 76314cd7..fa5ae278 100644 --- a/R/length.R +++ b/R/length.R @@ -76,7 +76,7 @@ xportr_length <- function(.df, ) } - ## Common section to detect default attributes + ## Common section to detect default arguments domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain diff --git a/R/metadata.R b/R/metadata.R index 0fda0c42..16964945 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -46,7 +46,7 @@ xportr_metadata <- function(.df, metadata = NULL, domain = NULL) { stop("Assertion failed on `metadata` and `domain`: Must provide either `metadata` or `domain` argument") } - ## Common section to detect default attributes + ## Common section to detect default arguments domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain diff --git a/R/order.R b/R/order.R index fac37ccc..84903466 100644 --- a/R/order.R +++ b/R/order.R @@ -72,7 +72,7 @@ xportr_order <- function(.df, ) } - ## Common section to detect default attributes + ## Common section to detect default arguments domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain diff --git a/R/type.R b/R/type.R index 16ca8518..919b30a2 100644 --- a/R/type.R +++ b/R/type.R @@ -90,7 +90,7 @@ xportr_type <- function(.df, ) } - ## Common section to detect default attributes + ## Common section to detect default arguments domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain diff --git a/R/write.R b/R/write.R index 3cd7e65d..ec201acb 100644 --- a/R/write.R +++ b/R/write.R @@ -52,11 +52,23 @@ xportr_write <- function(.df, domain = NULL, strict_checks = FALSE, label = deprecated()) { - ## Common section to detect default attributes + if (!missing(label)) { + lifecycle::deprecate_warn( + when = "0.3.2", + what = "xportr_write(label = )", + with = "xportr_write(metadata = )" + ) + assert_string(label, null.ok = TRUE, max.chars = 40) + metadata <- data.frame(dataset = domain, label = label) + } + + ## Common section to detect default arguments domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain + metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") + ## End of common section assert_data_frame(.df) @@ -68,15 +80,6 @@ xportr_write <- function(.df, name <- tools::file_path_sans_ext(basename(path)) - if (!missing(label)) { - lifecycle::deprecate_warn( - when = "0.3.2", - what = "xportr_write(label = )", - with = "xportr_write(metadata = )" - ) - assert_string(label, null.ok = TRUE, max.chars = 40) - metadata <- data.frame(dataset = domain, label = label) - } if (!is.null(metadata)) { .df <- xportr_df_label(.df, metadata = metadata, domain = domain) } From dd5bdc3b082f6b3528a3ceb8e5318f21ce2aec87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 22 Jan 2024 23:18:05 +0100 Subject: [PATCH 30/31] fix: remove extra empty line --- R/metadata.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/metadata.R b/R/metadata.R index 16964945..83d30286 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -41,7 +41,6 @@ #' xportr_order() #' } xportr_metadata <- function(.df, metadata = NULL, domain = NULL) { - if (is.null(metadata) && is.null(domain)) { stop("Assertion failed on `metadata` and `domain`: Must provide either `metadata` or `domain` argument") } From 9836f8b0522f9693939451464d666d0b42f74f80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 22 Jan 2024 23:25:36 +0100 Subject: [PATCH 31/31] revert: no longer retrieve metadata attribute as default --- R/metadata.R | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/R/metadata.R b/R/metadata.R index 83d30286..9211cca6 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -50,14 +50,11 @@ xportr_metadata <- function(.df, metadata = NULL, domain = NULL) { domain <- domain %||% attr(.df, "_xportr.df_arg_") if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain - metadata <- metadata %||% attr(.df, "_xportr.df_metadata_") - if (!is.null(metadata)) attr(.df, "_xportr.df_metadata_") <- metadata - ## End of common section assert_data_frame(.df) assert_metadata(metadata, include_fun_message = FALSE, null.ok = TRUE) assert_string(domain, null.ok = TRUE) - .df + structure(.df, `_xportr.df_metadata_` = metadata) }