Merge pull request #190 from atorus-research/175-assertions

Closes #175 Adds assertions to exported functions

NAMESPACE

@@ -18,6 +18,19 @@ export(xportr_write)
 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_integer)
+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_string)
+importFrom(checkmate,vname)
 importFrom(cli,cli_alert_danger)
 importFrom(cli,cli_alert_info)
 importFrom(cli,cli_alert_success)
@@ -49,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)

NEWS.md

@@ -7,13 +7,13 @@
 * Added a check for character variable lengths up to 200 bytes in `xpt_validate()`(#91, #189).
 * File name check is moved to strict_checks condition to allow underscores in the file name. Underscores are allowed in xpt but not per FDA requirements. (#126)
 * It is now possible to get and set the xportr options using the helper function `xportr_options()` (#130)
+* Adds argument assertions to public functions using `{checkmate}` (#175)
 
 ## Deprecation and Breaking Changes
 
 * The `domain` argument for xportr functions will no longer be dynamically 
 determined by the name of the data frame passed as the .df argument. This was
 done to make the use of xportr functions more explicit. (#182)
-
 * The `label` argument from the `xportr_write()` function is deprecated in favor of the `metadata` argument. (#179)
 * The `metacore` argument, which was renamed to `metadata` in the following six xportr functions: (`xportr_df_label()`, `xportr_format()`, `xportr_label()`, `xportr_length()`, `xportr_order()`, and `xportr_type()`) in version `0.3.0` with a soft deprecation warning, has now been hard deprecated. Please update your code to use the new `metadata` argument in place of `metacore`.
 

R/df_label.R

@@ -50,34 +50,32 @@ xportr_df_label <- function(.df,
       with = "xportr_df_label(metadata = )"
     )
   }
-  domain_name <- getOption("xportr.df_domain_name")
-  label_name <- getOption("xportr.df_label")
 
-  ## Common section to detect domain from argument or attribute
+  ## Common section to detect default arguments
 
-  domain <- get_domain(.df, domain)
+  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
 
-  ## Pull out correct metadata
-  metadata <- metadata %||%
-    attr(.df, "_xportr.df_metadata_") %||%
-    rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`")
+  assert_data_frame(.df)
+  assert_string(domain, null.ok = TRUE)
+  assert_metadata(metadata)
 
-  if (inherits(metadata, "Metacore")) {
-    metadata <- metadata$ds_spec
-  }
+  domain_name <- getOption("xportr.df_domain_name")
+  label_name <- getOption("xportr.df_label")
+
+  if (inherits(metadata, "Metacore")) metadata <- metadata$ds_spec
 
   label <- metadata %>%
     filter(!!sym(domain_name) == domain) %>%
     select(!!sym(label_name)) %>%
     # If a dataframe is used this will also be a dataframe, change to character.
     as.character()
 
-  label_len <- nchar(label)
-
-  if (label_len > 40) {
+  if (!test_string(label, max.chars = 40)) {
     abort("Length of dataset label must be 40 characters or less.")
   }
 

R/format.R

@@ -52,24 +52,25 @@ xportr_format <- function(.df,
       with = "xportr_format(metadata = )"
     )
   }
-  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 attribute
+  ## Common section to detect default arguments
 
-  domain <- get_domain(.df, domain)
+  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
 
-  metadata <- metadata %||%
-    attr(.df, "_xportr.df_metadata_") %||%
-    rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`")
+  assert_data_frame(.df)
+  assert_string(domain, null.ok = TRUE)
+  assert_metadata(metadata)
 
-  if (inherits(metadata, "Metacore")) {
-    metadata <- metadata$var_spec
-  }
+  domain_name <- getOption("xportr.domain_name")
+  format_name <- getOption("xportr.format_name")
+  variable_name <- getOption("xportr.variable_name")
+
+  if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec
 
   if (domain_name %in% names(metadata) && !is.null(domain)) {
     metadata <- metadata %>%

R/label.R

@@ -68,24 +68,26 @@ xportr_label <- function(.df,
       with = "xportr_label(metadata = )"
     )
   }
-  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 attribute
+  ## Common section to detect default arguments
 
-  domain <- get_domain(.df, domain)
+  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
 
-  metadata <- metadata %||%
-    attr(.df, "_xportr.df_metadata_") %||%
-    rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`")
+  assert_data_frame(.df)
+  assert_string(domain, null.ok = TRUE)
+  assert_metadata(metadata)
+  assert_choice(verbose, choices = .internal_verbose_choices)
 
-  if (inherits(metadata, "Metacore")) {
-    metadata <- metadata$var_spec
-  }
+  domain_name <- getOption("xportr.domain_name")
+  variable_name <- getOption("xportr.variable_name")
+  variable_label <- getOption("xportr.label")
+
+  if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec
 
   if (domain_name %in% names(metadata) && !is.null(domain)) {
     metadata <- metadata %>%
@@ -117,10 +119,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]]
     }
   }
 

R/length.R

@@ -75,24 +75,26 @@ xportr_length <- function(.df,
       with = "xportr_length(metadata = )"
     )
   }
-  domain_name <- getOption("xportr.domain_name")
-  variable_length <- getOption("xportr.length")
-  variable_name <- getOption("xportr.variable_name")
 
-  ## Common section to detect domain from argument or attribute
+  ## Common section to detect default arguments
 
-  domain <- get_domain(.df, domain)
+  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
 
-  metadata <- metadata %||%
-    attr(.df, "_xportr.df_metadata_") %||%
-    rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`")
+  assert_data_frame(.df)
+  assert_string(domain, null.ok = TRUE)
+  assert_metadata(metadata)
+  assert_choice(verbose, choices = .internal_verbose_choices)
 
-  if (inherits(metadata, "Metacore")) {
-    metadata <- metadata$var_spec
-  }
+  domain_name <- getOption("xportr.domain_name")
+  variable_length <- getOption("xportr.length")
+  variable_name <- getOption("xportr.variable_name")
+
+  if (inherits(metadata, "Metacore")) metadata <- metadata$var_spec
 
   if (domain_name %in% names(metadata) && !is.null(domain)) {
     metadata <- metadata %>%
@@ -102,7 +104,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]])
 

R/messages.R

@@ -10,6 +10,9 @@
 #' @return Output to Console
 #' @export
 xportr_logger <- function(message, type = "none", ...) {
+  assert_character(message)
+  assert_choice(type, 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(
@@ -76,6 +82,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")
@@ -97,6 +107,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 +132,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 +157,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(

R/metadata.R

@@ -42,14 +42,19 @@
 #' }
 xportr_metadata <- function(.df, metadata = NULL, domain = NULL) {
   if (is.null(metadata) && is.null(domain)) {
-    stop("Must provide either metadata or domain argument")
+    stop("Assertion failed on `metadata` and `domain`: Must provide either `metadata` or `domain` argument")
   }
-  ## Common section to detect domain from argument or attribute
 
-  domain <- get_domain(.df, domain)
+  ## Common section to detect default arguments
+
+  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_metadata(metadata, include_fun_message = FALSE, null.ok = TRUE)
+  assert_string(domain, null.ok = TRUE)
+
   structure(.df, `_xportr.df_metadata_` = metadata)
 }

R/order.R

@@ -71,24 +71,26 @@ xportr_order <- function(.df,
       with = "xportr_order(metadata = )"
     )
   }
-  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 attribute
+  ## Common section to detect default arguments
 
-  domain <- get_domain(.df, domain)
+  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
 
-  metadata <- metadata %||%
-    attr(.df, "_xportr.df_metadata_") %||%
-    rlang::abort("Metadata must be set with `metadata` or `xportr_metadata()`")
+  assert_data_frame(.df)
+  assert_string(domain, null.ok = TRUE)
+  assert_metadata(metadata)
+  assert_choice(verbose, choices = .internal_verbose_choices)
 
-  if (inherits(metadata, "Metacore")) {
-    metadata <- metadata$ds_vars
-  }
+  domain_name <- getOption("xportr.domain_name")
+  order_name <- getOption("xportr.order_name")
+  variable_name <- getOption("xportr.variable_name")
+
+  if (inherits(metadata, "Metacore")) metadata <- metadata$ds_vars
 
   if (domain_name %in% names(metadata) && !is.null(domain)) {
     metadata <- metadata %>%