diff --git a/DESCRIPTION b/DESCRIPTION index 3f43b38e..464bbdf6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -4,7 +4,7 @@ Title: Fast and Versatile Argument Checks Description: Tests and assertions to perform frequent argument checks. A substantial part of the package was written in C to minimize any worries about execution time overhead. -Version: 2.3.3 +Version: 2.3.4 Authors@R: c( person("Michel", "Lang", NULL, "michellang@gmail.com", role = c("cre", "aut"), comment = c(ORCID = "0000-0001-9754-0393")), @@ -38,7 +38,7 @@ Suggests: tibble License: BSD_3_clause + file LICENSE VignetteBuilder: knitr -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Collate: 'AssertCollection.R' 'allMissing.R' @@ -47,6 +47,7 @@ Collate: 'anyNaN.R' 'asInteger.R' 'assert.R' + 'makeXFunction.R' 'helper.R' 'makeExpectation.R' 'makeTest.R' diff --git a/NEWS.md b/NEWS.md index 5e8e230c..34757a0c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# Version 2.3.4 +* Refactored `makeXFunction` variants (`makeAssertionFunction`, `makeTestFunction`, + `makeExpectationFunction`) to fix #281, #283, and #284. + # Version 2.3.3 * Fixed a minor bug in `allMissing()` for complex numbers where either the real part or the imaginary part was missing while the other part was not missing diff --git a/R/makeAssertion.R b/R/makeAssertion.R index 8f15ba69..94145316 100644 --- a/R/makeAssertion.R +++ b/R/makeAssertion.R @@ -55,41 +55,6 @@ makeAssertion = function(x, res, var.name, collection) { #' @param coerce [\code{logical(1)}]\cr #' If \code{TRUE}, injects some lines of code to convert numeric values to integer after an successful assertion. #' Currently used in \code{\link{assertCount}}, \code{\link{assertInt}} and \code{\link{assertIntegerish}}. +#' @include makeXFunction.R #' @export -makeAssertionFunction = function(check.fun, c.fun = NULL, use.namespace = TRUE, coerce = FALSE, env = parent.frame()) { - fun.name = if (is.character(check.fun)) check.fun else deparse(substitute(check.fun)) - check.fun = match.fun(check.fun) - check.args = fun.args = formals(args(check.fun)) - x.name = names(fun.args[1L]) - new.fun = function() TRUE - - body = sprintf("if (missing(%s)) stop(sprintf(\"argument \\\"%%s\\\" is missing, with no default\", .var.name))", x.name) - - if (is.null(c.fun)) { - body = paste0(body, sprintf("; res = %s(%s)", fun.name, paste0(names(check.args), collapse = ", "))) - } else { - body = paste0(body, sprintf("; res = .Call(%s)", paste0(c(c.fun, names(check.args)), collapse = ", "))) - } - - if (coerce) { - fun.args = c(fun.args, alist(coerce = FALSE)) - } - - if (use.namespace) { - fun.args = c(fun.args, list(.var.name = bquote(checkmate::vname(.(as.name(x.name)))), add = NULL)) - body = paste0(body, "; checkmate::makeAssertion") - } else { - fun.args = c(fun.args, list(.var.name = bquote(vname(.(as.name(x.name)))), add = NULL)) - body = paste0(body, "; makeAssertion") - } - body = paste0(body, sprintf("(%s, res, .var.name, add)", x.name)) - - if (coerce) { - body = paste0(body, "; if (isTRUE(coerce) && is.double(x)) x = setNames(as.integer(round(x, 0L)), names(x)); invisible(x)") - } - - formals(new.fun) = fun.args - body(new.fun) = parse(text = paste("{", body, "}")) - environment(new.fun) = env - return(new.fun) -} +makeAssertionFunction = makeXFunctionFactory("assertion") diff --git a/R/makeExpectation.R b/R/makeExpectation.R index 468eb175..0df64888 100644 --- a/R/makeExpectation.R +++ b/R/makeExpectation.R @@ -110,33 +110,6 @@ makeExpectation = function(x, res, info, label) { #' @rdname makeExpectation #' @template makeFunction #' @template use.namespace +#' @include makeXFunction.R #' @export -makeExpectationFunction = function(check.fun, c.fun = NULL, use.namespace = FALSE, env = parent.frame()) { - fun.name = if (!is.character(check.fun)) deparse(substitute(check.fun)) else check.fun - check.fun = match.fun(check.fun) - check.args = fun.args = formals(args(check.fun)) - x.name = names(fun.args[1L]) - x = NULL - - new.fun = function() TRUE - body = sprintf("if (missing(%s)) stop(sprintf(\"Argument '%%s' is missing\", label))", x.name) - - if (is.null(c.fun)) { - body = paste0(body, sprintf("; res = %s(%s)", fun.name, paste0(names(check.args), collapse = ", "))) - } else { - body = paste0(body, sprintf("; res = .Call(%s)", paste0(c(c.fun, names(check.args)), collapse = ", "))) - } - - if (use.namespace) { - formals(new.fun) = c(fun.args, alist(info = NULL, label = checkmate::vname(x))) - body = paste0(body, "; checkmate::makeExpectation") - } else { - formals(new.fun) = c(fun.args, alist(info = NULL, label = vname(x))) - body = paste0(body, "; makeExpectation") - } - body = paste0(body, sprintf("(%s, res, info, label)", x.name)) - - body(new.fun) = parse(text = paste("{", body, "}")) - environment(new.fun) = env - return(new.fun) -} +makeExpectationFunction = makeXFunctionFactory("expectation") diff --git a/R/makeTest.R b/R/makeTest.R index 890d4c94..e2755cd3 100644 --- a/R/makeTest.R +++ b/R/makeTest.R @@ -34,21 +34,6 @@ makeTest = function(res) { #' @rdname makeTest #' @template makeFunction +#' @include makeXFunction.R #' @export -makeTestFunction = function(check.fun, c.fun = NULL, env = parent.frame()) { - fun.name = if (is.character(check.fun)) check.fun else deparse(substitute(check.fun)) - check.fun = match.fun(check.fun) - fun.args = formals(args(check.fun)) - - new.fun = function() TRUE - formals(new.fun) = fun.args - if (is.null(c.fun)) { - body = paste0("isTRUE(", fun.name, "(", paste0(names(fun.args), collapse = ", "), "))") - } else { - body = paste0("isTRUE(.Call(", paste0(c(c.fun, names(fun.args)), collapse = ", "), "))") - } - - body(new.fun) = parse(text = paste("{", body, "}")) - environment(new.fun) = env - return(new.fun) -} +makeTestFunction = makeXFunctionFactory("test") diff --git a/R/makeXFunction.R b/R/makeXFunction.R new file mode 100644 index 00000000..6e0161a2 --- /dev/null +++ b/R/makeXFunction.R @@ -0,0 +1,91 @@ +.makeXFunction <- function(x, check.fun, c.fun, use.namespace, coerce, env) { + x = match.arg(x, choices = c("assertion", "expectation", "test")) + check.fun.name = if (is.character(check.fun)) as.name(check.fun) else substitute(check.fun, env = parent.frame()) + check.fun = match.fun(check.fun) + new.fun <- local({ + new.fun.body = call("{") + new.fun.args = check.fun.args = formals(args(check.fun)) + first.arg.name = as.name(names(check.fun.args[1L])) + if (is.null(c.fun)) { + inner.fun.args = lapply(names(check.fun.args), as.name) + inner.fun.call = as.call(c(check.fun.name, inner.fun.args)) + not.dots.args.idx = which(names(check.fun.args) != "...") + names(inner.fun.call)[not.dots.args.idx + 1L] = names(check.fun.args)[not.dots.args.idx] + } else { + inner.fun.args = lapply(names(check.fun.args), as.name) + inner.fun.call = as.call(c(quote(.Call), c.fun, inner.fun.args)) + } + new.fun.body[[length(new.fun.body) + 1L]] = call("=", quote(res), inner.fun.call) + if (x == "test") { + new.fun.body[[length(new.fun.body) + 1L]] = quote(isTRUE(res)) + return(list(body = new.fun.body, args = new.fun.args)) + } + if (use.namespace) { + .vname = quote(checkmate::vname) + .makeX = switch( + x, + assertion = quote(checkmate::makeAssertion), + expectation = quote(checkmate::makeExpectation) + ) + } else { + .vname = quote(vname) + .makeX = switch( + x, + assertion = quote(makeAssertion), + expectation = quote(makeExpectation) + ) + } + .var.name = bquote(.(.vname)(.(first.arg.name))) + if (x == "assertion") { + new.fun.args = c(new.fun.args, if (isTRUE(coerce)) list(coerce = FALSE) else NULL, list(.var.name = .var.name, add = NULL)) + makeX.call = bquote(.(.makeX)(x = .(first.arg.name), res = res, var.name = .var.name, collection = add)) + } else if (x == "expectation") { + new.fun.args = c(new.fun.args, list(info = NULL, label = .var.name)) + makeX.call = bquote(.(.makeX)(x = .(first.arg.name), res = res, info = info, label = label)) + } + new.fun.body[[length(new.fun.body) + 1L]] = makeX.call + if (x == "expectation") { + return(list(body = new.fun.body, args = new.fun.args)) + } + if (isTRUE(coerce)) { + new.fun.body[[length(new.fun.body) + 1L]] = bquote(if (isTRUE(coerce) && is.double(.(first.arg.name))) .(first.arg.name) = setNames(as.integer(round(.(first.arg.name), 0L)), names(.(first.arg.name)))) + new.fun.body[[length(new.fun.body) + 1L]] = bquote(invisible(.(first.arg.name))) + } + return(list(body = new.fun.body, args = new.fun.args)) + }) + eval(call("function", as.pairlist(new.fun$args), new.fun$body), envir = env) +} + +makeXFunctionFactory <- function(x) { + x = match.arg(x, choices = c("assertion", "expectation", "test")) + switch( + x, + assertion = function(check.fun, c.fun = NULL, use.namespace = TRUE, coerce = FALSE, env = parent.frame()) { + .makeXFunction( + x = "assertion", + check.fun = check.fun, + c.fun = c.fun, + use.namespace = use.namespace, + coerce = coerce, + env = env + ) + }, + expectation = function(check.fun, c.fun = NULL, use.namespace = FALSE, env = parent.frame()) { + .makeXFunction( + x = "expectation", + check.fun = check.fun, + c.fun = c.fun, + use.namespace = use.namespace, + env = env + ) + }, + test = function(check.fun, c.fun = NULL, env = parent.frame()) { + .makeXFunction( + x = "test", + check.fun = check.fun, + c.fun = c.fun, + env = env + ) + } + ) +} diff --git a/tests/testthat/test_makeFunction.R b/tests/testthat/test_makeFunction.R index b1ff28fb..730be647 100644 --- a/tests/testthat/test_makeFunction.R +++ b/tests/testthat/test_makeFunction.R @@ -49,21 +49,53 @@ test_that("makeExpectation", { }) test_that("makeX with name for 'x' not 'x'", { - checker = function(foo, bar = TRUE) check_numeric(foo) + checker = function(foo, bar = FALSE) checkFlag(foo, na.ok = bar) achecker = makeAssertionFunction(checker) expect_identical(names(formals(achecker)), c("foo", "bar", ".var.name", "add")) - expect_identical(as.character(formals(achecker)$.var.name)[2], "foo") - expect_equal(sum(grepl("foo", as.character(body(achecker)))), 3L) - expect_equal(sum(grepl("bar", as.character(body(achecker)))), 1L) + expect_error(achecker(), 'argument "foo" is missing') + expect_identical(achecker(FALSE), FALSE) + expect_error(achecker(1L), "Assertion on '1L' failed") + expect_error(achecker(NA), "May not be NA") + expect_identical(achecker(NA, bar = TRUE), NA) + expect_error(achecker(NA, bar = "x"), "'na.ok' must be a flag") tchecker = makeTestFunction(checker) expect_identical(names(formals(tchecker)), c("foo", "bar")) - expect_equal(sum(grepl("foo", as.character(body(tchecker)))), 1L) - expect_equal(sum(grepl("bar", as.character(body(tchecker)))), 1L) + expect_error(tchecker(), 'argument "foo" is missing') + expect_true(tchecker(FALSE)) + expect_false(tchecker(1L)) + expect_false(tchecker(NA)) + expect_true(tchecker(NA, bar = TRUE)) + expect_error(tchecker(NA, bar = "x"), "'na.ok' must be a flag") echecker = makeExpectationFunction(checker) expect_identical(names(formals(echecker)), c("foo", "bar", "info", "label")) - expect_equal(sum(grepl("foo", as.character(body(echecker)))), 3L) - expect_equal(sum(grepl("bar", as.character(body(echecker)))), 1L) + expect_error(echecker(), 'argument "foo" is missing') + expect_identical(echecker(FALSE), FALSE) + expect_error(echecker(1L), "Check on '1L' failed") + expect_error(echecker(NA), "May not be NA") + expect_identical(echecker(NA, bar = TRUE), NA) + expect_error(echecker(NA, bar = "x"), "'na.ok' must be a flag") +}) + +test_that("makeXFunction works with named args trailing `...`", { + checker = function(object, ..., force.fail = FALSE) { + if (isTRUE(force.fail)) return("Forced failure") + TRUE + } + + achecker = makeAssertionFunction(checker) + expect_error(achecker(), 'argument "object" is missing') + expect_identical(achecker("foo"), "foo") + expect_error(achecker("foo", force.fail = TRUE), ".+foo.+Forced failure") + + tchecker = makeTestFunction(checker) + expect_true(tchecker("foo")) + expect_false(tchecker("foo", force.fail = TRUE)) + + echecker = makeExpectationFunction(checker) + expect_error(echecker(), 'argument "object" is missing') + expect_identical(echecker("foo"), "foo") + expect_error(echecker("foo", force.fail = TRUE), ".+foo.+Forced failure") })