Improve makeXFunction variants (fixes #281, #283, #284)

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'

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

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

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

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

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
+      )
+    }
+  )
+}

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")
 })