refactor: use checkmate for validation where possible, fix tests

Author: dshemetov

DESCRIPTION

@@ -26,6 +26,7 @@ Description: This package introduces a common data structure for epidemiological
 License: MIT + file LICENSE
 Copyright: file inst/COPYRIGHTS
 Imports:
+    checkmate,
     cli,
     data.table,
     dplyr (>= 1.0.0),

NAMESPACE

@@ -61,6 +61,22 @@ export(slice)
 export(ungroup)
 export(unnest)
 importFrom(R6,R6Class)
+importFrom(checkmate,anyNaN)
+importFrom(checkmate,assert)
+importFrom(checkmate,assert_character)
+importFrom(checkmate,assert_class)
+importFrom(checkmate,assert_data_frame)
+importFrom(checkmate,assert_int)
+importFrom(checkmate,assert_list)
+importFrom(checkmate,assert_logical)
+importFrom(checkmate,assert_numeric)
+importFrom(checkmate,assert_scalar)
+importFrom(checkmate,assert_set_equal)
+importFrom(checkmate,assert_subset)
+importFrom(checkmate,check_atomic)
+importFrom(checkmate,check_data_frame)
+importFrom(checkmate,check_scalar)
+importFrom(checkmate,vname)
 importFrom(cli,cli_abort)
 importFrom(cli,cli_inform)
 importFrom(cli,cli_warn)

R/archive.R

@@ -27,8 +27,8 @@ validate_version_bound <- function(version_bound, x, na_ok = FALSE,
                                    x_arg = rlang::caller_arg(version_bound)) {
 
   if (na_ok && is.na(version_bound)) return(invisible(NULL))
-  checkmate::assert_set_equal(class(version_bound), class(x[["version"]]), .var.name = version_bound_arg)
-  checkmate::assert_set_equal(typeof(version_bound), typeof(x[["version"]]), .var.name = version_bound_arg)
+  assert_set_equal(class(version_bound), class(x[["version"]]), .var.name = version_bound_arg)
+  assert_set_equal(typeof(version_bound), typeof(x[["version"]]), .var.name = version_bound_arg)
 
   return(invisible(NULL))
 }
@@ -246,26 +246,9 @@ epi_archive <-
       initialize = function(x, geo_type, time_type, other_keys,
                             additional_metadata, compactify,
                             clobberable_versions_start, versions_end) {
-        # Check that we have a data frame
-        if (!is.data.frame(x)) {
-          cli_abort("`x` must be a data frame.")
-        }
-
-        # Check that we have geo_value, time_value, version columns
-        if (!("geo_value" %in% names(x))) {
-          cli_abort("`x` must contain a `geo_value` column.")
-        }
-        if (!("time_value" %in% names(x))) {
-          cli_abort("`x` must contain a `time_value` column.")
-        }
-        if (!("version" %in% names(x))) {
-          cli_abort("`x` must contain a `version` column.")
-        }
-        if (anyNA(x$version)) {
-          cli_abort("`x$version` must not contain `NA`s",
-            class = "epiprocess__version_values_must_not_be_na"
-          )
-        }
+        assert_data_frame(x)
+        assert_subset(c("geo_value", "time_value", "version"), names(x))
+        assert(!anyNaN(x$version))
 
         # If geo type is missing, then try to guess it
         if (missing(geo_type)) {
@@ -461,22 +444,13 @@ epi_archive <-
         if (length(other_keys) == 0) other_keys <- NULL
 
         # Check a few things on max_version
-        if (!identical(class(max_version), class(self$DT$version)) ||
-          !identical(typeof(max_version), typeof(self$DT$version))) {
-          cli_abort("`max_version` and `DT$version` must have same `class` and `typeof`.")
-        }
-        if (length(max_version) != 1) {
-          cli_abort("`max_version` cannot be a vector.")
-        }
-        if (is.na(max_version)) {
-          cli_abort("`max_version` must not be NA.")
-        }
+        assert_set_equal(class(max_version), class(self$DT$version))
+        assert_set_equal(typeof(max_version), typeof(self$DT$version))
+        assert_scalar(max_version, na.ok = FALSE)
         if (max_version > self$versions_end) {
           cli_abort("`max_version` must be at most `self$versions_end`.")
         }
-        if (!rlang::is_bool(all_versions)) {
-          cli_abort("`all_versions` must be TRUE or FALSE.")
-        }
+        assert_logical(all_versions, len = 1)
         if (!is.na(self$clobberable_versions_start) && max_version >= self$clobberable_versions_start) {
           cli_warn('Getting data as of some recent version which could still be overwritten (under routine circumstances) without assigning a new version number (a.k.a. "clobbered").  Thus, the snapshot that we produce here should not be expected to be reproducible later. See `?epi_archive` for more info and `?epix_as_of` on how to muffle.',
             class = "epiprocess__snapshot_as_of_clobberable_version"
@@ -589,16 +563,9 @@ epi_archive <-
       #' @param x as in [`epix_truncate_versions_after`]
       #' @param max_version as in [`epix_truncate_versions_after`]
       truncate_versions_after = function(max_version) {
-        if (length(max_version) != 1) {
-          cli_abort("`max_version` cannot be a vector.")
-        }
-        if (is.na(max_version)) {
-          cli_abort("`max_version` must not be NA.")
-        }
-        if (!identical(class(max_version), class(self$DT$version)) ||
-          !identical(typeof(max_version), typeof(self$DT$version))) {
-          cli_abort("`max_version` and `DT$version` must have same `class` and `typeof`.")
-        }
+        assert_set_equal(class(max_version), class(self$DT$version))
+        assert_set_equal(typeof(max_version), typeof(self$DT$version))
+        assert_scalar(max_version, na.ok = FALSE)
         if (max_version > self$versions_end) {
           cli_abort("`max_version` must be at most `self$versions_end`.")
         }

R/correlation.R

@@ -78,8 +78,7 @@
 epi_cor <- function(x, var1, var2, dt1 = 0, dt2 = 0, shift_by = geo_value,
                     cor_by = geo_value, use = "na.or.complete",
                     method = c("pearson", "kendall", "spearman")) {
-  # Check we have an `epi_df` object
-  if (!inherits(x, "epi_df")) cli_abort("`x` must be of class `epi_df`.")
+  assert_class(x, "epi_df")
 
   # Check that we have variables to do computations on
   if (missing(var1)) cli_abort("`var1` must be specified.")

R/epi_df.R

@@ -114,14 +114,9 @@ NULL
 #' @export
 new_epi_df <- function(x = tibble::tibble(), geo_type, time_type, as_of,
                        additional_metadata = list(), ...) {
-  # Check that we have a data frame
-  if (!is.data.frame(x)) {
-    cli_abort("`x` must be a data frame.")
-  }
+  assert_data_frame(x)
+  assert_list(additional_metadata)
 
-  if (!is.list(additional_metadata)) {
-    cli_abort("`additional_metadata` must be a list type.")
-  }
   if (is.null(additional_metadata[["other_keys"]])) {
     additional_metadata[["other_keys"]] <- character(0L)
   }
@@ -302,13 +297,7 @@ as_epi_df.epi_df <- function(x, ...) {
 #' @export
 as_epi_df.tbl_df <- function(x, geo_type, time_type, as_of,
                              additional_metadata = list(), ...) {
-  # Check that we have geo_value and time_value columns
-  if (!("geo_value" %in% names(x))) {
-    cli_abort("`x` must contain a `geo_value` column.")
-  }
-  if (!("time_value" %in% names(x))) {
-    cli_abort("`x` must contain a `time_value` column.")
-  }
+  assert_subset(c("geo_value", "time_value"), names(x))
 
   new_epi_df(
     x, geo_type, time_type, as_of,

R/epiprocess.R

@@ -7,5 +7,9 @@
 #' @docType package
 #' @name epiprocess
 #' @importFrom cli cli_abort cli_inform cli_warn
+#' @importFrom checkmate assert assert_scalar assert_data_frame assert_subset
+#'             assert_set_equal anyNaN assert_logical assert_list
+#'             assert_character assert_class assert_int assert_numeric
+#'             check_scalar check_data_frame vname check_atomic
 NULL
 utils::globalVariables(c(".x", ".group_key", ".ref_time_value"))

R/grouped_epi_archive.R

@@ -59,35 +59,14 @@ grouped_epi_archive <-
             epiprocess__ungrouped_groups = groups(ungrouped)
           )
         }
-        if (!inherits(ungrouped, "epi_archive")) {
-          cli_abort("`ungrouped` must be an epi_archive",
-            class = "epiprocess__grouped_epi_archive__ungrouped_arg_is_not_epi_archive",
-            epiprocess__ungrouped_class = class(ungrouped)
-          )
-        }
-        if (!is.character(vars)) {
-          cli_abort("`vars` must be a character vector (any tidyselection should have already occurred in a helper method).",
-            class = "epiprocess__grouped_epi_archive__vars_is_not_chr",
-            epiprocess__vars_class = class(vars),
-            epiprocess__vars_type = typeof(vars)
-          )
-        }
-        if (!all(vars %in% names(ungrouped$DT))) {
-          cli_abort("`vars` must be selected from the names of columns of `ungrouped$DT`",
-            class = "epiprocess__grouped_epi_archive__vars_contains_invalid_entries",
-            epiprocess__vars = vars,
-            epiprocess__DT_names = names(ungrouped$DT)
-          )
-        }
+        assert_class(ungrouped, "epi_archive")
+        assert_character(vars)
+        assert_subset(vars, names(ungrouped$DT))
         if ("version" %in% vars) {
           cli_abort("`version` has a special interpretation and cannot be used by itself as a grouping variable")
         }
-        if (!rlang::is_bool(drop)) {
-          cli_abort("`drop` must be a Boolean",
-            class = "epiprocess__grouped_epi_archive__drop_is_not_bool",
-            epiprocess__drop = drop
-          )
-        }
+        assert_logical(drop)
+
         # -----
         private$ungrouped <- ungrouped
         private$vars <- vars
@@ -136,9 +115,7 @@ grouped_epi_archive <-
         invisible(self)
       },
       group_by = function(..., .add = FALSE, .drop = dplyr::group_by_drop_default(self)) {
-        if (!rlang::is_bool(.add)) {
-          cli_abort("`.add` must be a Boolean")
-        }
+        assert_logical(.add)
         if (!.add) {
           cli_abort('`group_by` on a `grouped_epi_archive` with `.add=FALSE` is forbidden
                  (neither automatic regrouping nor nested grouping is supported).
@@ -230,15 +207,8 @@ grouped_epi_archive <-
 
         if (missing(ref_time_values)) {
           ref_time_values <- epix_slide_ref_time_values_default(private$ungrouped)
-        } else if (length(ref_time_values) == 0L) {
-          cli_abort("`ref_time_values` must have at least one element.")
-        } else if (any(is.na(ref_time_values))) {
-          cli_abort("`ref_time_values` must not include `NA`.")
-        } else if (anyDuplicated(ref_time_values) != 0L) {
-          cli_abort("`ref_time_values` must not contain any duplicates; use `unique` if appropriate.")
-        } else if (any(ref_time_values > private$ungrouped$versions_end)) {
-          cli_abort("All `ref_time_values` must be `<=` the `versions_end`.")
         } else {
+          assert_numeric(ref_time_values, upper = private$ungrouped$versions_end, min.len = 1L, null.ok = FALSE, any.missing = FALSE)
           # Sort, for consistency with `epi_slide`, although the current
           # implementation doesn't take advantage of it.
           ref_time_values <- sort(ref_time_values)
@@ -253,9 +223,7 @@ grouped_epi_archive <-
                      `before=365000`).")
         }
         before <- vctrs::vec_cast(before, integer())
-        if (length(before) != 1L || is.na(before) || before < 0L) {
-          cli_abort("`before` must be length-1, non-NA, non-negative.")
-        }
+        assert_int(before, lower = 0L, null.ok = FALSE, na.ok = FALSE)
 
         # If a custom time step is specified, then redefine units
 
@@ -265,15 +233,9 @@ grouped_epi_archive <-
         new_col <- sym(new_col_name)
 
         # Validate rest of parameters:
-        if (!rlang::is_bool(as_list_col)) {
-          cli_abort("`as_list_col` must be TRUE or FALSE.")
-        }
-        if (!(rlang::is_string(names_sep) || is.null(names_sep))) {
-          cli_abort("`names_sep` must be a (single) string or NULL.")
-        }
-        if (!rlang::is_bool(all_versions)) {
-          cli_abort("`all_versions` must be TRUE or FALSE.")
-        }
+        assert_logical(as_list_col, len = 1L)
+        assert_logical(all_versions, len = 1L)
+        assert_character(names_sep, len = 1L, null.ok = TRUE)
 
         # Computation for one group, one time value
         comp_one_grp <- function(.data_group, .group_key,
@@ -290,9 +252,7 @@ grouped_epi_archive <-
             .data_group <- .data_group$DT
           }
 
-          if (!(is.atomic(comp_value) || is.data.frame(comp_value))) {
-            cli_abort("The slide computation must return an atomic vector or a data frame.")
-          }
+          assert(check_atomic(comp_value, any.missing = TRUE), check_data_frame(comp_value), combine = "or", .var.name = vname(comp_value))
 
           # Label every result row with the `ref_time_value`
           res <- list(time_value = ref_time_value)

R/growth_rate.R

@@ -119,9 +119,7 @@ growth_rate <- function(x = seq_along(y), y, x0 = x,
                         dup_rm = FALSE, na_rm = FALSE, ...) {
   # Check x, y, x0
   if (length(x) != length(y)) cli_abort("`x` and `y` must have the same length.")
-  if (!all(x0 %in% x)) cli_abort("`x0` must be a subset of `x`.")
-
-  # Check the method
+  assert_subset(x0, x)
   method <- match.arg(method)
 
   # Arrange in increasing order of x

R/methods-epi_archive.R

@@ -70,14 +70,14 @@
 #'       max_version = max(archive_cases_dv_subset$DT$version)
 #'     )
 #'   },
-#'   epiprocess__snapshot_as_of_clobberable_version = function(wrn) invokeRestart("mufflecli_warning")
+#'   epiprocess__snapshot_as_of_clobberable_version = function(wrn) invokeRestart("muffleWarning")
 #' )
 #' # Since R 4.0, there is a `globalCallingHandlers` function that can be used
 #' # to globally toggle these warnings.
 #'
 #' @export
 epix_as_of <- function(x, max_version, min_time_value = -Inf, all_versions = FALSE) {
-  if (!inherits(x, "epi_archive")) cli_abort("`x` must be of class `epi_archive`.")
+  assert_class(x, "epi_archive")
   return(x$as_of(max_version, min_time_value, all_versions = all_versions))
 }
 
@@ -113,7 +113,7 @@ epix_as_of <- function(x, max_version, min_time_value = -Inf, all_versions = FAL
 #' @return An `epi_archive`
 epix_fill_through_version <- function(x, fill_versions_end,
                                       how = c("na", "locf")) {
-  if (!inherits(x, "epi_archive")) cli_abort("`x` must be of class `epi_archive`.")
+  assert_class(x, "epi_archive")
   # Enclosing parentheses drop the invisibility flag. See description above of
   # potential mutation and aliasing behavior.
   (x$clone()$fill_through_version(fill_versions_end, how = how))
@@ -179,14 +179,8 @@ epix_fill_through_version <- function(x, fill_versions_end,
 epix_merge <- function(x, y,
                        sync = c("forbid", "na", "locf", "truncate"),
                        compactify = TRUE) {
-  if (!inherits(x, "epi_archive")) {
-    cli_abort("`x` must be of class `epi_archive`.")
-  }
-
-  if (!inherits(y, "epi_archive")) {
-    cli_abort("`y` must be of class `epi_archive`.")
-  }
-
+  assert_class(x, "epi_archive")
+  assert_class(y, "epi_archive")
   sync <- rlang::arg_match(sync)
 
   if (!identical(x$geo_type, y$geo_type)) {
@@ -409,11 +403,7 @@ epix_merge <- function(x, y,
 #'
 #' @noRd
 new_col_modify_recorder_df <- function(parent_df) {
-  if (!inherits(parent_df, "data.frame")) {
-    cli_abort('`parent_df` must inherit class `"data.frame"`',
-      internal = TRUE
-    )
-  }
+  assert_class(parent_df, "data.frame")
   `class<-`(parent_df, c("col_modify_recorder_df", class(parent_df)))
 }
 
@@ -425,11 +415,7 @@ new_col_modify_recorder_df <- function(parent_df) {
 #'
 #' @noRd
 destructure_col_modify_recorder_df <- function(col_modify_recorder_df) {
-  if (!inherits(col_modify_recorder_df, "col_modify_recorder_df")) {
-    cli_abort('`col_modify_recorder_df` must inherit class `"col_modify_recorder_df"`',
-      internal = TRUE
-    )
-  }
+  assert_class(col_modify_recorder_df, "col_modify_recorder_df")
   list(
     unchanged_parent_df = col_modify_recorder_df %>%
       `attr<-`("epiprocess::col_modify_recorder_df::cols", NULL) %>%
@@ -676,9 +662,7 @@ epix_detailed_restricted_mutate <- function(.data, ...) {
 group_by.epi_archive <- function(.data, ..., .add = FALSE, .drop = dplyr::group_by_drop_default(.data)) {
   # `add` makes no difference; this is an ungrouped `epi_archive`.
   detailed_mutate <- epix_detailed_restricted_mutate(.data, ...)
-  if (!rlang::is_bool(.drop)) {
-    cli_abort("`.drop` must be TRUE or FALSE")
-  }
+  assert_logical(.drop)
   if (!.drop) {
     grouping_cols <- as.list(detailed_mutate[["archive"]][["DT"]])[detailed_mutate[["request_names"]]]
     grouping_col_is_factor <- purrr::map_lgl(grouping_cols, is.factor)

R/outliers.R

@@ -108,10 +108,8 @@ detect_outlr <- function(x = seq_along(y), y,
     results <- do.call(method, args = c(list("x" = x, "y" = y), args))
 
     # Validate the output
-    if (!is.data.frame(results) ||
-      !all(c("lower", "upper", "replacement") %in% colnames(results))) {
-      cli_abort("Outlier detection method must return a data frame with columns `lower`, `upper`, and `replacement`.")
-    }
+    assert_data_frame(results)
+    assert_subset(c("lower", "upper", "replacement"), colnames(results))
 
     # Update column names with model abbreviation
     colnames(results) <- paste(abbr, colnames(results), sep = "_")