Fix #281: custom checks with args trailing ...

R/helper.R

@@ -112,3 +112,25 @@ check_disjunct_internal = function(x, y, match, what = NULL) {
 
   return(TRUE)
 }
+
+
+# Generates the call to the check function that goes
+# in the body of functions produced by makeXFunction
+call_check_string <- function(fun.name, c.fun, check.args) {
+  args <- vapply(names(check.args), \(name) {
+    if (identical(
+      as.character(check.args[[name]]),
+      # ideally, below should be a representation of
+      # empty arg and above should not have `as.character`
+      # but could not figure out how to generate this representation
+      character(1)
+    )) name
+    else paste(name, "=", name)
+  }, character(1))
+
+  if (!is.null(c.fun)) {
+    fun.name <- ".Call"
+    args <- c(c.fun, args)
+  }
+  sprintf("%s(%s)", fun.name, paste0(args, collapse = ", "))
+}

R/makeAssertion.R

@@ -65,11 +65,7 @@ makeAssertionFunction = function(check.fun, c.fun = NULL, use.namespace = 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 = ", ")))
-  }
+  body = paste0(body, "; res = ", call_check_string(fun.name, c.fun, check.args))
 
   if (coerce) {
     fun.args = c(fun.args, alist(coerce = FALSE))

R/makeExpectation.R

@@ -121,11 +121,7 @@ makeExpectationFunction = function(check.fun, c.fun = NULL, use.namespace = FALS
   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 = ", ")))
-  }
+  body = paste0(body, "; res = ", call_check_string(fun.name, c.fun, check.args))
 
   if (use.namespace) {
     formals(new.fun) = c(fun.args, alist(info = NULL, label = checkmate::vname(x)))

R/makeTest.R

@@ -42,11 +42,8 @@ makeTestFunction = function(check.fun, c.fun = NULL, env = parent.frame()) {
 
   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 = paste0("isTRUE(", call_check_string(fun.name, c.fun, fun.args), ")")
 
   body(new.fun) = parse(text = paste("{", body, "}"))
   environment(new.fun) = env

tests/testthat/test_makeFunction.R

@@ -67,3 +67,24 @@ test_that("makeX with name for 'x' not 'x'", {
   expect_equal(sum(grepl("foo", as.character(body(echecker)))), 3L)
   expect_equal(sum(grepl("bar", as.character(body(echecker)))), 1L)
 })
+
+
+test_that("makeXFunction works with named args trailing `...`", {
+
+  checker <- function(x, ..., should.pass =  TRUE) if (should.pass) TRUE else "FAIL"
+  expect_true(checker("foo", should.pass = TRUE))
+  expect_equal(checker("foo", should.pass = FALSE), "FAIL")
+
+  achecker <- checkmate::makeAssertionFunction(checker)
+  expect_equal(expect_no_error(achecker("foo", should.pass = TRUE)), "foo")
+  expect_error(achecker("foo", should.pass = FALSE), "Assertion on '\"foo\"' failed: FAIL.")
+
+  tchecker <- checkmate::makeTestFunction(checker)
+  expect_true(tchecker("foo", should.pass = TRUE))
+  expect_false(tchecker("foo", should.pass = FALSE))
+
+  echecker <- checkmate::makeExpectationFunction(checker)
+  expect_equal(echecker("foo", should.pass = TRUE), "foo")
+  expect_error(echecker("foo", should.pass = FALSE), "Check on '\"foo\"' failed: FAIL")
+
+})