From ad92b1943015b9a8b2696d663be073a423cdc4fc Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Fri, 30 Aug 2024 14:48:28 +0100 Subject: [PATCH 1/3] Use standalone assertions from reside.utils --- .covrignore | 1 + .gitattributes | 1 + R/import-standalone-utils-assert.R | 180 +++++++++++++++++++++++++++++ R/util_assert.R | 102 ---------------- tests/testthat/test-util-assert.R | 41 ------- 5 files changed, 182 insertions(+), 143 deletions(-) create mode 100644 .covrignore create mode 100644 .gitattributes create mode 100644 R/import-standalone-utils-assert.R delete mode 100644 R/util_assert.R delete mode 100644 tests/testthat/test-util-assert.R diff --git a/.covrignore b/.covrignore new file mode 100644 index 00000000..d90e23c9 --- /dev/null +++ b/.covrignore @@ -0,0 +1 @@ +R/import-*.R diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..39c9638d --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +R/import-*.R linguist-generated=true diff --git a/R/import-standalone-utils-assert.R b/R/import-standalone-utils-assert.R new file mode 100644 index 00000000..99ed450a --- /dev/null +++ b/R/import-standalone-utils-assert.R @@ -0,0 +1,180 @@ +# Standalone file: do not edit by hand +# Source: https://github.com/reside-ic/reside.utils/blob/prototype/R/standalone-utils-assert.R +# Generated by: usethis::use_standalone("reside-ic/reside.utils", "utils-assert", ref = "prototype") +# ---------------------------------------------------------------------- +# +# --- +# repo: reside/reside.utils +# file: standalone-utils-assert.R +# imports: cli +# --- +assert_scalar <- function(x, name = deparse(substitute(x)), arg = name, + call = parent.frame()) { + if (length(x) != 1) { + cli::cli_abort( + c("'{name}' must be a scalar", + i = "{name} has length {length(x)}"), + call = call, arg = arg) + } + invisible(x) +} + + +assert_character <- function(x, name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + if (!is.character(x)) { + cli::cli_abort("Expected '{name}' to be character", call = call, arg = arg) + } + invisible(x) +} + + +assert_numeric <- function(x, name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + if (!is.numeric(x)) { + cli::cli_abort("Expected '{name}' to be numeric", call = call, arg = arg) + } + invisible(x) +} + + +assert_integer <- function(x, name = deparse(substitute(x)), + tolerance = NULL, arg = name, + call = parent.frame()) { + if (is.numeric(x)) { + rx <- round(x) + if (is.null(tolerance)) { + tolerance <- sqrt(.Machine$double.eps) + } + if (!isTRUE(all.equal(x, rx, tolerance = tolerance))) { + cli::cli_abort( + c("Exected '{name}' to be integer", + i = paste("{cli::qty(length(x))}The provided", + "{?value was/values were} numeric, but not very close", + "to integer values")), + arg = arg, call = call) + } + x <- as.integer(rx) + } else { + cli::cli_abort("Exected '{name}' to be integer", call = call, arg = arg) + } + invisible(x) +} + + +assert_logical <- function(x, name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + if (!is.logical(x)) { + cli::cli_abort("Expected '{name}' to be logical", arg = arg, call = call) + } + invisible(x) +} + + +assert_nonmissing <- function(x, name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + if (anyNA(x)) { + cli::cli_abort("Expected '{name}' to be non-NA", arg = arg, call = call) + } + invisible(x) +} + + +assert_scalar_character <- function(x, name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + assert_scalar(x, name, arg = arg, call = call) + assert_character(x, name, arg = arg, call = call) + assert_nonmissing(x, name, arg = arg, call = call) +} + + +assert_scalar_numeric <- function(x, name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + assert_scalar(x, name, arg = arg, call = call) + assert_numeric(x, name, arg = arg, call = call) + assert_nonmissing(x, name, arg = arg, call = call) +} + + +assert_scalar_integer <- function(x, name = deparse(substitute(x)), + tolerance = NULL, arg = name, call = parent.frame()) { + assert_scalar(x, name, arg = arg, call = call) + assert_integer(x, name, tolerance = tolerance, arg = arg, call = call) + assert_nonmissing(x, name, arg = arg, call = call) +} + + +assert_scalar_logical <- function(x, name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + assert_scalar(x, name, arg = arg, call = call) + assert_logical(x, name, arg = arg, call = call) + assert_nonmissing(x, name, arg = arg, call = call) +} + + +assert_scalar_size <- function(x, allow_zero = TRUE, + name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + assert_scalar_integer(x, name = name, arg = arg, call = call) + assert_nonmissing(x, name, arg = arg, call = call) + min <- if (allow_zero) 0 else 1 + if (x < min) { + cli::cli_abort("'{name}' must be at least {min}", arg = arg, call = call) + } + invisible(x) +} + + +assert_length <- function(x, len, name = deparse(substitute(x)), arg = name, + call = parent.frame()) { + if (length(x) != len) { + cli::cli_abort( + "Expected '{name}' to have length {len}, but was length {length(x)}", + arg = arg, call = call) + } + invisible(x) +} + + +assert_is <- function(x, what, name = deparse(substitute(x)), arg = name, + call = parent.frame()) { + if (!inherits(x, what)) { + cli::cli_abort("Expected '{name}' to be a '{what}' object", + arg = arg, call = call) + } + invisible(x) +} + + +assert_named <- function(x, unique = FALSE, name = deparse(substitute(x)), + arg = name, call = parent.frame()) { + nms <- names(x) + if (is.null(nms)) { + cli::cli_abort("'{name}' must be named", call = call, arg = arg) + } + if (anyNA(nms) || any(nms == "")) { + cli::cli_abort("All elements of '{name}' must be named", + call = call, arg = arg) + } + if (unique && anyDuplicated(names(x))) { + dups <- sprintf("'%s'", unique(names(x)[duplicated(names(x))])) + cli::cli_abort( + c("'{name}' must have unique names", + i = "Found {length(dups)} duplicate{?s}: {dups}"), + call = call, arg = arg) + } + invisible(x) +} + + +match_value <- function(x, choices, name = deparse(substitute(x)), arg = name, + call = parent.frame()) { + assert_scalar_character(x, call = call, arg = arg) + if (!(x %in% choices)) { + choices_str <- paste(sprintf("'%s'", choices), collapse = ", ") + cli::cli_abort(c("'{name}' must be one of {choices_str}", + i = "Instead we were given '{x}'"), call = call, + arg = arg) + } + x +} diff --git a/R/util_assert.R b/R/util_assert.R deleted file mode 100644 index 4e1963a9..00000000 --- a/R/util_assert.R +++ /dev/null @@ -1,102 +0,0 @@ -assert_is <- function(x, what, name = deparse(substitute(x)), - call = parent.frame()) { - if (!inherits(x, what)) { - cli::cli_abort("Expected '{name}' to be a '{what}' object", - arg = name, call = call) - } - invisible(x) -} - - -assert_scalar <- function(x, name = deparse(substitute(x)), arg = name, - call = NULL) { - if (length(x) != 1) { - cli::cli_abort( - c("'{name}' must be a scalar", - i = "{name} has length {length(x)}"), - call = call, arg = arg) - } - invisible(x) -} - - -assert_logical <- function(x, name = deparse(substitute(x)), - arg = name, call = NULL) { - if (!is.logical(x)) { - cli::cli_abort("Expected '{name}' to be logical", arg = arg, call = call) - } - invisible(x) -} - - -assert_character <- function(x, name = deparse(substitute(x)), - arg = name, call = NULL) { - if (!is.character(x)) { - cli::cli_abort("Expected '{name}' to be character", call = call, arg = arg) - } - invisible(x) -} - - -assert_nonmissing <- function(x, name = deparse(substitute(x)), - arg = name, call = NULL) { - if (anyNA(x)) { - cli::cli_abort("Expected '{name}' to be non-NA", arg = arg, call = call) - } - invisible(x) -} - - -assert_scalar_logical <- function(x, name = deparse(substitute(x)), - arg = name, call = NULL) { - assert_scalar(x, name, arg = arg, call = call) - assert_logical(x, name, arg = arg, call = call) - assert_nonmissing(x, name, arg = arg, call = call) -} - - -assert_scalar_character <- function(x, name = deparse(substitute(x)), - arg = name, call = NULL) { - assert_scalar(x, name, arg = arg, call = call) - assert_character(x, name, arg = arg, call = call) - assert_nonmissing(x, name, arg = arg, call = call) -} - - -assert_named <- function(x, unique = FALSE, name = deparse(substitute(x)), - arg = name, call = parent.frame()) { - if (is.null(names(x))) { - cli::cli_abort("'{name}' must be named", call = call, arg = arg) - } - if (unique && anyDuplicated(names(x))) { - dups <- unique(names(x)[duplicated(names(x))]) - cli::cli_abort( - c("'{name}' must have unique names", - i = "Found {length(dups)} duplicate{?s}: {collapseq(dups)}"), - call = call, arg = arg) - } - invisible(x) -} - - -assert_list <- function(x, name = deparse(substitute(x)), arg = name, - call = parent.frame()) { - if (!is.list(x)) { - cli::cli_abort("Expected '{name}' to be a list", - arg = arg, call = call) - } - invisible(x) -} - - -match_value <- function(x, choices, name = deparse(substitute(x)), arg = name, - call = NULL) { - assert_scalar_character(x, call = call, arg = arg) - if (!(x %in% choices)) { - choices_str <- paste(squote(choices), collapse = ", ") - cli::cli_abort(c("'{name}' must be one of {choices_str}", - i = "Instead we were given '{x}'"), call = call, - arg = arg) - } - x -} diff --git a/tests/testthat/test-util-assert.R b/tests/testthat/test-util-assert.R deleted file mode 100644 index bc6d3f94..00000000 --- a/tests/testthat/test-util-assert.R +++ /dev/null @@ -1,41 +0,0 @@ -test_that("assert_scalar", { - expect_error(assert_scalar(NULL), "must be a scalar") - expect_error(assert_scalar(numeric(0)), "must be a scalar") - expect_error(assert_scalar(1:2), "must be a scalar") -}) - - -test_that("assert_character", { - expect_silent(assert_character("a")) - expect_error(assert_character(1), "to be character") - expect_error(assert_character(TRUE), "to be character") -}) - - -test_that("assert_logical", { - expect_silent(assert_logical(TRUE)) - expect_error(assert_logical(1), "Expected '1' to be logical") - expect_error(assert_logical("a"), "Expected '\"a\"' to be logical") -}) - - -test_that("assert_nonmissing", { - expect_silent(assert_nonmissing(TRUE)) - expect_error(assert_nonmissing(NA), "Expected 'NA' to be non-NA") - x <- c(1, NA) - expect_error(assert_nonmissing(x), "Expected 'x' to be non-NA") -}) - - -test_that("match_value", { - expect_error(match_value("foo", letters), "must be one of") - expect_silent(match_value("a", letters)) -}) - - -test_that("assert_list", { - expect_silent(assert_list(list())) - expect_silent(assert_list(list(a = 1))) - x <- c(a = 1) - expect_error(assert_list(x), "Expected 'x' to be a list") -}) From 660e4903eb9109283d8c8e1c0b02d53e39afb931 Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Fri, 30 Aug 2024 14:48:41 +0100 Subject: [PATCH 2/3] Bump version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d58425f1..ce7ac01b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: monty Title: Monte Carlo Models -Version: 0.2.2 +Version: 0.2.3 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"), email = "rich.fitzjohn@gmail.com"), person("Wes", "Hinsley", role = "aut"), From 5f09223811f425537dc539277bc900eab4a43f23 Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Fri, 30 Aug 2024 14:53:24 +0100 Subject: [PATCH 3/3] Add missing utility --- R/import-standalone-utils-assert.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/R/import-standalone-utils-assert.R b/R/import-standalone-utils-assert.R index 99ed450a..67adf3bf 100644 --- a/R/import-standalone-utils-assert.R +++ b/R/import-standalone-utils-assert.R @@ -146,6 +146,16 @@ assert_is <- function(x, what, name = deparse(substitute(x)), arg = name, } +assert_list <- function(x, name = deparse(substitute(x)), arg = name, + call = parent.frame()) { + if (!is.list(x)) { + cli::cli_abort("Expected '{name}' to be a list", + arg = arg, call = call) + } + invisible(x) +} + + assert_named <- function(x, unique = FALSE, name = deparse(substitute(x)), arg = name, call = parent.frame()) { nms <- names(x)