From 1685beb48b181c79a7e5b942234c8193895f1d8b Mon Sep 17 00:00:00 2001 From: Brock Date: Tue, 11 Nov 2025 14:05:10 +0100 Subject: [PATCH 1/2] Fix #281: custom checks with args trailing `...` --- R/helper.R | 22 ++++++++++++++++++++++ R/makeAssertion.R | 6 +----- R/makeExpectation.R | 6 +----- R/makeTest.R | 7 ++----- tests/testthat/test_makeFunction.R | 21 +++++++++++++++++++++ 5 files changed, 47 insertions(+), 15 deletions(-) diff --git a/R/helper.R b/R/helper.R index 7bcdca6a..0fc041c6 100644 --- a/R/helper.R +++ b/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 = ", ")) +} \ No newline at end of file diff --git a/R/makeAssertion.R b/R/makeAssertion.R index 8f15ba69..b9b65bcd 100644 --- a/R/makeAssertion.R +++ b/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)) diff --git a/R/makeExpectation.R b/R/makeExpectation.R index 468eb175..d5ffc180 100644 --- a/R/makeExpectation.R +++ b/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))) diff --git a/R/makeTest.R b/R/makeTest.R index 890d4c94..7ce8e31a 100644 --- a/R/makeTest.R +++ b/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 diff --git a/tests/testthat/test_makeFunction.R b/tests/testthat/test_makeFunction.R index b1ff28fb..b9ed08f8 100644 --- a/tests/testthat/test_makeFunction.R +++ b/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") + +}) \ No newline at end of file From c0c60feb3b9274ce166a8217784f95eec487635b Mon Sep 17 00:00:00 2001 From: Brock Date: Tue, 11 Nov 2025 15:40:20 +0100 Subject: [PATCH 2/2] fix line endings --- R/helper.R | 2 +- tests/testthat/test_makeFunction.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/helper.R b/R/helper.R index 0fc041c6..26bc90d4 100644 --- a/R/helper.R +++ b/R/helper.R @@ -133,4 +133,4 @@ call_check_string <- function(fun.name, c.fun, check.args) { args <- c(c.fun, args) } sprintf("%s(%s)", fun.name, paste0(args, collapse = ", ")) -} \ No newline at end of file +} diff --git a/tests/testthat/test_makeFunction.R b/tests/testthat/test_makeFunction.R index b9ed08f8..a85ecb8d 100644 --- a/tests/testthat/test_makeFunction.R +++ b/tests/testthat/test_makeFunction.R @@ -87,4 +87,4 @@ test_that("makeXFunction works with named args trailing `...`", { expect_equal(echecker("foo", should.pass = TRUE), "foo") expect_error(echecker("foo", should.pass = FALSE), "Check on '\"foo\"' failed: FAIL") -}) \ No newline at end of file +})