Closes #175 Adds assertions to exported functions

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),

NAMESPACE

@@ -18,6 +18,17 @@ 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,test_r6)
+importFrom(checkmate,test_string)
 importFrom(cli,cli_alert_danger)
 importFrom(cli,cli_alert_info)
 importFrom(cli,cli_alert_success)

R/df_label.R

@@ -51,6 +51,14 @@ 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")
 
@@ -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.")
   }
 

R/format.R

@@ -53,6 +53,14 @@ 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)
+  )
+  assert_string(domain, null.ok = TRUE)
+
   domain_name <- getOption("xportr.domain_name")
   format_name <- getOption("xportr.format_name")
   variable_name <- getOption("xportr.variable_name")
@@ -68,7 +76,7 @@ xportr_format <- function(.df,
     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
   }
 

R/label.R

@@ -69,6 +69,15 @@ 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)
+  )
+  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")
@@ -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]]
     }
   }
 

R/length.R

@@ -76,6 +76,15 @@ 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)
+  )
+  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")
@@ -91,7 +100,7 @@ xportr_length <- function(.df,
     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]])
 

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

@@ -41,14 +41,22 @@
 #'     xportr_order()
 #' }
 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
 
   ## End of common section
 
-  structure(.df, `_xportr.df_metadata_` = metadata)
+  structure(.df, "_xportr.df_metadata_" = metadata)
 }
 
 
@@ -61,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

R/order.R

@@ -72,6 +72,15 @@ 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)
+  )
+  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")
@@ -87,7 +96,7 @@ xportr_order <- function(.df,
     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
   }
 

R/type.R

@@ -89,6 +89,15 @@ 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)
+  )
+  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")
@@ -109,7 +118,7 @@ xportr_type <- function(.df,
     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"]])
 

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 ----
@@ -310,11 +312,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 <character>.",
-      x = glue("Instead, it has type <{typeof(domain)}>.")
-    ))
-  }
+  assert_string(domain, null.ok = TRUE)
 
   result <- domain %||% attr(.df, "_xportr.df_arg_")
   result
@@ -372,3 +370,7 @@ check_multiple_var_specs <- function(metadata,
     )
   }
 }
+
+#' Internal choices for verbose option
+#' @noRd
+.internal_verbose_choices <- c("none", "warn", "message", "stop")

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

R/xportr-package.R

@@ -108,6 +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
 #'
 "_PACKAGE"