From a8d28747fd3c3b233e9293eb6941bbe5b1625449 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 10 Jan 2022 15:27:30 -0600 Subject: [PATCH 01/15] Rename signature to dispatch_args Fixes #116 --- R/generic.R | 38 ++++++++++++++--------------- R/method.R | 6 ++--- R/zzz.R | 6 ++--- README.Rmd | 6 ++--- README.md | 8 +++--- man/method.Rd | 2 +- man/new_generic.Rd | 6 ++--- src/code.c | 4 +-- tests/testthat/_snaps/generic.md | 14 +++++------ tests/testthat/t0/R/pkg.R | 2 +- tests/testthat/t1/R/foo.R | 2 +- tests/testthat/test-generic.R | 36 +++++++++++++-------------- tests/testthat/test-method.R | 42 ++++++++++++++++---------------- vignettes/case_studies.Rmd | 2 +- vignettes/performance.Rmd | 12 ++++----- 15 files changed, 93 insertions(+), 93 deletions(-) diff --git a/R/generic.R b/R/generic.R index cf12f7e1..66ed5998 100644 --- a/R/generic.R +++ b/R/generic.R @@ -7,7 +7,7 @@ #' #' @param name The name of the generic. This should be the same as the object #' that you assign it to. -#' @param signature A character vector providing the names of arguments to +#' @param dispatch_args A character vector providing the names of arguments to #' dispatch on. If omitted, defaults to the required arguments of `fun`. #' @param fun An optional specification of the generic, which must call #' `method_call()` to dispatch to methods. This is usually generated @@ -19,7 +19,7 @@ #' @export #' @examples #' # A simple generic with methods for some base types and S3 classes -#' type_of <- new_generic("type_of", signature = "x") +#' type_of <- new_generic("type_of", dispatch_args = "x") #' method(type_of, "character") <- function(x, ...) "A character vector" #' method(type_of, "data.frame") <- function(x, ...) "A data frame" #' method(type_of, "function") <- function(x, ...) "A function" @@ -41,45 +41,45 @@ #' } #' method(mean2, "character") <- function(x, ...) {stop("Not supported")} #' -new_generic <- function(name, fun = NULL, signature = NULL) { - if (is.null(signature) && is.null(fun)) { +new_generic <- function(name, fun = NULL, dispatch_args = NULL) { + if (is.null(dispatch_args) && is.null(fun)) { stop( - "Must call `new_generic()` with at least one of `signature` or `fun`", + "Must call `new_generic()` with at least one of `dispatch_args` or `fun`", call. = FALSE ) } - if (is.null(signature)) { + if (is.null(dispatch_args)) { check_generic(fun) - signature <- guess_signature(fun) + dispatch_args <- guess_dispatch_args(fun) } else { - signature <- check_signature(signature) - # For now, ensure all generics have ... in signature - signature <- union(signature, "...") + dispatch_args <- check_dispatch_args(dispatch_args) + # For now, ensure all generics have ... in dispatch_args + dispatch_args <- union(dispatch_args, "...") if (is.null(fun)) { - args <- setNames(lapply(signature, function(i) quote(expr = )), signature) + args <- setNames(lapply(dispatch_args, function(i) quote(expr = )), dispatch_args) fun <- make_function(args, quote(method_call()), topenv(environment())) } } - R7_generic(name = name, signature = signature, fun = fun) + R7_generic(name = name, dispatch_args = dispatch_args, fun = fun) } -guess_signature <- function(fun) { +guess_dispatch_args <- function(fun) { formals <- formals(fun) is_required <- vlapply(formals, identical, quote(expr = )) names(formals[is_required]) } -check_signature <- function(signature) { - if (!is.character(signature)) { - stop("`signature` must be a character vector", call. = FALSE) +check_dispatch_args <- function(dispatch_args) { + if (!is.character(dispatch_args)) { + stop("`dispatch_args` must be a character vector", call. = FALSE) } - if (length(signature) == 0) { - stop("`signature` must have at least one component", call. = FALSE) + if (length(dispatch_args) == 0) { + stop("`dispatch_args` must have at least one component", call. = FALSE) } - signature + dispatch_args } #' @export diff --git a/R/method.R b/R/method.R index 35277304..bcb46fd2 100644 --- a/R/method.R +++ b/R/method.R @@ -19,7 +19,7 @@ #' @export #' @examples #' # Create a generic -#' bizarro <- new_generic("bizarro", signature = "x") +#' bizarro <- new_generic("bizarro", dispatch_args = "x") #' # Register some methods #' method(bizarro, "numeric") <- function(x, ...) rev(x) #' method(bizarro, "factor") <- function(x, ...) { @@ -81,7 +81,7 @@ method_impl <- function(generic, signature, ignore) { if (is.null(out)) { # If no R7 method is found, see if there are any S3 methods registered if (inherits(generic, "R7_generic")) { - args <- generic@signature + args <- generic@dispatch_args generic <- generic@name } else { generic <- find_function_name(generic, topenv(environment(generic))) @@ -129,7 +129,7 @@ next_method <- function() { generic <- current_method # Find signature - dispatch_on <- setdiff(generic@signature, "...") + dispatch_on <- setdiff(generic@dispatch_args, "...") vals <- mget(dispatch_on, envir = parent.frame()) signature <- lapply(vals, object_class) diff --git a/R/zzz.R b/R/zzz.R index a8921ece..f814437d 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -24,10 +24,10 @@ base_constructors <- lapply(base_types, get) R7_generic <- new_class( name = "R7_generic", - properties = list(name = "character", methods = "environment", signature = new_property(name = "signature", getter = function(x) formals(x@.data))), + properties = list(name = "character", methods = "environment", dispatch_args = new_property(name = "dispatch_args", getter = function(x) formals(x@.data))), parent = "function", - constructor = function(name, signature, fun) { - new_object(name = name, signature = signature, methods = new.env(parent = emptyenv(), hash = TRUE), .data = fun) + constructor = function(name, dispatch_args, fun) { + new_object(name = name, dispatch_args = dispatch_args, methods = new.env(parent = emptyenv(), hash = TRUE), .data = fun) } ) diff --git a/README.Rmd b/README.Rmd index 40a85eec..d598d228 100644 --- a/README.Rmd +++ b/README.Rmd @@ -99,7 +99,7 @@ names(y@.data) ```{r} text <- new_class("text", parent = "character", constructor = function(text) new_object(.data = text)) -foo <- new_generic("foo", signature = "x") +foo <- new_generic("foo", dispatch_args = "x") method(foo, "text") <- function(x, ...) paste0("foo-", x) @@ -118,7 +118,7 @@ At each level the search iteratively searches along objects class vector. ```{r} number <- new_class("number", parent = "numeric", constructor = function(x) new_object(.data = x)) -bar <- new_generic("bar", signature = c("x", "y")) +bar <- new_generic("bar", dispatch_args = c("x", "y")) method(bar, list("character", "numeric")) <- function(x, y, ...) paste0("foo-", x, ":", y) @@ -145,7 +145,7 @@ bar(text("hi"), number(42)) `method_call()` retains promises for dispatch arguments in basically the same way as `UseMethod()`, so non-standard evaluation works basically the same as S3. ```{r} -subset2 <- new_generic("subset2", signature = "x") +subset2 <- new_generic("subset2", dispatch_args = "x") method(subset2, "data.frame") <- function(x, subset = NULL, select = NULL, drop = FALSE, ...) { e <- substitute(subset) diff --git a/README.md b/README.md index dff2baac..2d87895f 100644 --- a/README.md +++ b/README.md @@ -65,7 +65,7 @@ x@length # incorrect properties throws an error x@middle -#> Error: Can't find property @middle +#> Error in prop(object, name): Can't find property @middle # assigning properties verifies the class matches the class of the value x@end <- "foo" @@ -110,7 +110,7 @@ names(y@.data) ``` r text <- new_class("text", parent = "character", constructor = function(text) new_object(.data = text)) -foo <- new_generic("foo", signature = "x") +foo <- new_generic("foo", dispatch_args = "x") method(foo, "text") <- function(x, ...) paste0("foo-", x) @@ -133,7 +133,7 @@ vector. ``` r number <- new_class("number", parent = "numeric", constructor = function(x) new_object(.data = x)) -bar <- new_generic("bar", signature = c("x", "y")) +bar <- new_generic("bar", dispatch_args = c("x", "y")) method(bar, list("character", "numeric")) <- function(x, y, ...) paste0("foo-", x, ":", y) @@ -165,7 +165,7 @@ same way as `UseMethod()`, so non-standard evaluation works basically the same as S3. ``` r -subset2 <- new_generic("subset2", signature = "x") +subset2 <- new_generic("subset2", dispatch_args = "x") method(subset2, "data.frame") <- function(x, subset = NULL, select = NULL, drop = FALSE, ...) { e <- substitute(subset) diff --git a/man/method.Rd b/man/method.Rd index 8f736666..89845aa8 100644 --- a/man/method.Rd +++ b/man/method.Rd @@ -30,7 +30,7 @@ interactively in order to see the implementation of a specific method. } \examples{ # Create a generic -bizarro <- new_generic("bizarro", signature = "x") +bizarro <- new_generic("bizarro", dispatch_args = "x") # Register some methods method(bizarro, "numeric") <- function(x, ...) rev(x) method(bizarro, "factor") <- function(x, ...) { diff --git a/man/new_generic.Rd b/man/new_generic.Rd index 99a1f1e9..cde83b1e 100644 --- a/man/new_generic.Rd +++ b/man/new_generic.Rd @@ -4,7 +4,7 @@ \alias{new_generic} \title{Define a new generic} \usage{ -new_generic(name, fun = NULL, signature = NULL) +new_generic(name, fun = NULL, dispatch_args = NULL) } \arguments{ \item{name}{The name of the generic. This should be the same as the object @@ -16,7 +16,7 @@ automatically from the \code{signature}, but you may want to supply it if you want to add additional required arguments, or perform some standardised computation in the generic.} -\item{signature}{A character vector providing the names of arguments to +\item{dispatch_args}{A character vector providing the names of arguments to dispatch on. If omitted, defaults to the required arguments of \code{fun}.} } \description{ @@ -26,7 +26,7 @@ of one or more arguments (the \code{signature}). Create a new generic with } \examples{ # A simple generic with methods for some base types and S3 classes -type_of <- new_generic("type_of", signature = "x") +type_of <- new_generic("type_of", dispatch_args = "x") method(type_of, "character") <- function(x, ...) "A character vector" method(type_of, "data.frame") <- function(x, ...) "A data frame" method(type_of, "function") <- function(x, ...) "A function" diff --git a/src/code.c b/src/code.c index 94e9ee37..f2f7654a 100644 --- a/src/code.c +++ b/src/code.c @@ -108,7 +108,7 @@ void R7_method_lookup_error(SEXP generic, SEXP signature, SEXP envir) { R7_method_lookup_error_fun = Rf_findVarInFrame(ns, Rf_install("method_lookup_error")); } SEXP name = Rf_getAttrib(generic, Rf_install("name")); - SEXP args = Rf_getAttrib(generic, Rf_install("signature")); + SEXP args = Rf_getAttrib(generic, Rf_install("dispatch_args")); SEXP R7_method_lookup_error_call = PROTECT(Rf_lang4(R7_method_lookup_error_fun, name, args, signature)); Rf_eval(R7_method_lookup_error_call, envir); } @@ -117,7 +117,7 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { int n_protect = 0; // Get the signature, the names of arguments to use for dispatch - SEXP gen_signature_args = Rf_getAttrib(generic, Rf_install("signature")); + SEXP gen_signature_args = Rf_getAttrib(generic, Rf_install("dispatch_args")); // Every generic signature has `...` as the last arg, which we want to ignore. R_xlen_t gen_signature_len = Rf_xlength(gen_signature_args); diff --git a/tests/testthat/_snaps/generic.md b/tests/testthat/_snaps/generic.md index 16e05b89..7b2eadf9 100644 --- a/tests/testthat/_snaps/generic.md +++ b/tests/testthat/_snaps/generic.md @@ -1,17 +1,17 @@ -# new_generic needs fun or signature +# new_generic needs fun or dispatch_args - Must call `new_generic()` with at least one of `signature` or `fun` + Must call `new_generic()` with at least one of `dispatch_args` or `fun` -# check_signature produces informative errors +# check_dispatch_args() produces informative errors Code - check_signature(1) + check_dispatch_args(1) Error - `signature` must be a character vector + `dispatch_args` must be a character vector Code - check_signature(character()) + check_dispatch_args(character()) Error - `signature` must have at least one component + `dispatch_args` must have at least one component # R7_generic printing diff --git a/tests/testthat/t0/R/pkg.R b/tests/testthat/t0/R/pkg.R index 48761b68..c9448a95 100644 --- a/tests/testthat/t0/R/pkg.R +++ b/tests/testthat/t0/R/pkg.R @@ -1,3 +1,3 @@ #' @importFrom R7 method object_class #' @export -bar <- R7::new_generic("bar", signature = c("x", "y")) +bar <- R7::new_generic("bar", dispatch_args = c("x", "y")) diff --git a/tests/testthat/t1/R/foo.R b/tests/testthat/t1/R/foo.R index c470aebd..293371b8 100644 --- a/tests/testthat/t1/R/foo.R +++ b/tests/testthat/t1/R/foo.R @@ -1,3 +1,3 @@ #' @importFrom R7 method object_class #' @export -foo <- R7::new_generic("foo", signature = c("x", "y")) +foo <- R7::new_generic("foo", dispatch_args = c("x", "y")) diff --git a/tests/testthat/test-generic.R b/tests/testthat/test-generic.R index 05eea054..72366c98 100644 --- a/tests/testthat/test-generic.R +++ b/tests/testthat/test-generic.R @@ -1,17 +1,17 @@ -test_that("new_generic needs fun or signature", { +test_that("new_generic needs fun or dispatch_args", { expect_snapshot_error(new_generic()) }) -test_that("signature overrules derived signature", { +test_that("dispatch_args overrules derived", { g <- new_generic("g", function(x, y, ...) method_call()) - expect_equal(g@signature, c("x", "y", "...")) + expect_equal(g@dispatch_args, c("x", "y", "...")) - g <- new_generic("g", function(x, y, ...) method_call(), signature = "x") - expect_equal(g@signature, c("x", "...")) + g <- new_generic("g", function(x, y, ...) method_call(), dispatch_args = "x") + expect_equal(g@dispatch_args, c("x", "...")) }) test_that("generics pass ... to methods, and methods can define additional arguments on basic types", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") new_method(foo, "character", function(x, sep = "-", ...) paste0("foo", sep, x)) expect_equal(foo("bar"), "foo-bar") @@ -19,30 +19,30 @@ test_that("generics pass ... to methods, and methods can define additional argum }) test_that("generics pass ... to methods, and methods can define additional arguments on R7 objects", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") new_method(foo, "text", function(x, sep = "-", ...) paste0("foo", sep, x)) expect_equal(foo(text("bar")), "foo-bar") expect_equal(foo(text("bar"), sep = "/"), "foo/bar") }) -test_that("guesses signature from required arguments", { - expect_equal(guess_signature(function() {}), NULL) - expect_equal(guess_signature(function(x) {}), "x") - expect_equal(guess_signature(function(x, y) {}), c("x", "y")) - expect_equal(guess_signature(function(x, y, ...) {}), c("x", "y", "...")) - expect_equal(guess_signature(function(x, ..., y = 1) {}), c("x", "...")) +test_that("guesses dispatch_args from required arguments", { + expect_equal(guess_dispatch_args(function() {}), NULL) + expect_equal(guess_dispatch_args(function(x) {}), "x") + expect_equal(guess_dispatch_args(function(x, y) {}), c("x", "y")) + expect_equal(guess_dispatch_args(function(x, y, ...) {}), c("x", "y", "...")) + expect_equal(guess_dispatch_args(function(x, ..., y = 1) {}), c("x", "...")) }) -test_that("check_signature produces informative errors", { +test_that("check_dispatch_args() produces informative errors", { expect_snapshot(error = TRUE, { - check_signature(1) - check_signature(character()) + check_dispatch_args(1) + check_dispatch_args(character()) }) }) test_that("R7_generic printing", { - foo <- new_generic(name = "foo", signature = c("x", "y", "z")) + foo <- new_generic(name = "foo", dispatch_args = c("x", "y", "z")) method(foo, list("character", text, "character")) <- function(x, y, z, ...) 1 method(foo, list("character", "integer", "character")) <- function(x, y, z, ...) 2 method(foo, list("character", "integer", "logical")) <- function(x, y, z, ...) 3 @@ -53,7 +53,7 @@ test_that("R7_generic printing", { }) test_that("R7_generic printing with long / many arguments", { - foo <- new_generic(name = "foo", signature = letters) + foo <- new_generic(name = "foo", dispatch_args = letters) expect_snapshot( foo ) diff --git a/tests/testthat/test-method.R b/tests/testthat/test-method.R index c47a58bb..db93bb3f 100644 --- a/tests/testthat/test-method.R +++ b/tests/testthat/test-method.R @@ -26,7 +26,7 @@ test_that("method errors on invalid inputs", { }) test_that("method errors if no method is defined for that class", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") expect_snapshot_error( method(foo, list("blah")) @@ -34,14 +34,14 @@ test_that("method errors if no method is defined for that class", { }) test_that("methods can be registered for a generic and then called", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") new_method(foo, "text", function(x, ...) paste0("foo-", x@.data)) expect_equal(foo(text("bar")), "foo-bar") }) test_that("single inheritance works when searching for methods", { - foo2 <- new_generic("foo2", signature = "x") + foo2 <- new_generic("foo2", dispatch_args = "x") new_method(foo2, "character", function(x, ...) paste0("foo2-", x)) @@ -49,20 +49,20 @@ test_that("single inheritance works when searching for methods", { }) test_that("direct multiple dispatch works", { - foo3 <- new_generic("foo3", signature = c("x", "y")) + foo3 <- new_generic("foo3", dispatch_args = c("x", "y")) new_method(foo3, list("text", "number"), function(x, y, ...) paste0(x, y)) expect_equal(foo3(text("bar"), number(1)), "bar1") }) test_that("inherited multiple dispatch works", { - foo4 <- new_generic("foo4", signature = c("x", "y")) + foo4 <- new_generic("foo4", dispatch_args = c("x", "y")) new_method(foo4, list("character", "numeric"), function(x, y, ...) paste0(x, ":", y)) expect_equal(foo4(text("bar"), number(1)), "bar:1") }) test_that("method dispatch works for S3 objects", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") obj <- structure("hi", class = "my_s3") @@ -77,7 +77,7 @@ test_that("method dispatch works for S3 objects", { Range <- setClass("Range", slots = c(start = "numeric", end = "numeric")) obj <- Range(start = 1, end = 10) - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") new_method(foo, "Range", function(x, ...) paste0("foo-", x@start, "-", x@end)) @@ -85,21 +85,21 @@ test_that("method dispatch works for S3 objects", { }) test_that("new_method works if you use R7 class objects", { - foo5 <- new_generic("foo5", signature = c("x", "y")) + foo5 <- new_generic("foo5", dispatch_args = c("x", "y")) new_method(foo5, list(text, number), function(x, y, ...) paste0(x, ":", y)) expect_equal(foo5(text("bar"), number(1)), "bar:1") }) test_that("new_method works if you pass a bare class", { - foo6 <- new_generic("foo6", signature = "x") + foo6 <- new_generic("foo6", dispatch_args = "x") new_method(foo6, text, function(x, ...) paste0("foo-", x)) expect_equal(foo6(text("bar")), "foo-bar") }) test_that("new_method works if you pass a bare class union", { - foo7 <- new_generic("foo7", signature = "x") + foo7 <- new_generic("foo7", dispatch_args = "x") new_method(foo7, new_union(text, number), function(x, ...) paste0("foo-", x)) expect_equal(foo7(text("bar")), "foo-bar") @@ -107,7 +107,7 @@ test_that("new_method works if you pass a bare class union", { }) test_that("next_method works for single dispatch", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") new_method(foo, "text", function(x, ...) { x@.data <- paste0("foo-", x@.data) @@ -122,7 +122,7 @@ test_that("next_method works for single dispatch", { }) test_that("next_method works for double dispatch", { - foo <- new_generic("foo", signature = c("x", "y")) + foo <- new_generic("foo", dispatch_args = c("x", "y")) new_method(foo, list("text", "number"), function(x, y, ...) { x@.data <- paste0("foo-", x@.data, "-", y@.data) @@ -143,7 +143,7 @@ test_that("next_method works for double dispatch", { }) test_that("substitute() works for single dispatch method calls like S3", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") new_method(foo, "character", function(x, ...) substitute(x)) @@ -152,7 +152,7 @@ test_that("substitute() works for single dispatch method calls like S3", { }) test_that("substitute() works for multiple dispatch method calls like S3", { - foo <- new_generic("foo", signature = c("x", "y")) + foo <- new_generic("foo", dispatch_args = c("x", "y")) new_method(foo, "character", function(x, y, ...) c(substitute(x), substitute(y))) @@ -162,7 +162,7 @@ test_that("substitute() works for multiple dispatch method calls like S3", { }) test_that("method_compatible returns TRUE if the functions are compatible", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") expect_true( method_compatible( @@ -187,7 +187,7 @@ test_that("method_compatible returns TRUE if the functions are compatible", { ) ) - bar <- new_generic("bar", signature = c("x", "y")) + bar <- new_generic("bar", dispatch_args = c("x", "y")) expect_true( method_compatible( function(x, y, ...) x, @@ -205,7 +205,7 @@ test_that("method_compatible returns TRUE if the functions are compatible", { }) test_that("method_compatible throws errors if the functions are not compatible", { - foo <- new_generic("foo", signature = "x") + foo <- new_generic("foo", dispatch_args = "x") # Different argument names expect_snapshot_error( @@ -231,7 +231,7 @@ test_that("method_compatible throws errors if the functions are not compatible", ) ) - bar <- new_generic("bar", signature = c("x", "y")) + bar <- new_generic("bar", dispatch_args = c("x", "y")) # Arguments in wrong order expect_snapshot_error( @@ -276,7 +276,7 @@ test_that("method compatible verifies that if a generic does not have dots the m }) test_that("method lookup fails with an informative message for single classes", { - foo <- new_generic(name="foo", signature = c("x", "y")) + foo <- new_generic(name="foo", dispatch_args = c("x", "y")) method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) expect_snapshot_error( foo(TRUE, list()) @@ -288,7 +288,7 @@ test_that("method lookup fails with an informative message for single classes", }) test_that("method lookup fails with an informative message for multiple classes", { - foo <- new_generic(name="foo", signature = c("x", "y")) + foo <- new_generic(name="foo", dispatch_args = c("x", "y")) method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) expect_snapshot_error( foo(tibble::tibble(), .POSIXct(double())) @@ -296,7 +296,7 @@ test_that("method lookup fails with an informative message for multiple classes" }) test_that("R7_method printing", { - foo <- new_generic(name="foo", signature = c("x", "y")) + foo <- new_generic(name="foo", dispatch_args = c("x", "y")) method(foo, list(text, "integer")) <- function(x, y, ...) paste0("bar:", x, y) expect_snapshot( method(foo, list(text, "integer")), diff --git a/vignettes/case_studies.Rmd b/vignettes/case_studies.Rmd index f603ebb1..b94c8f0c 100644 --- a/vignettes/case_studies.Rmd +++ b/vignettes/case_studies.Rmd @@ -177,7 +177,7 @@ We next define a `R7_subset` generic function, and then a R7 method for that fun The subsets the individual components appropriately and then returns a new `annotated_df` object with them. ```{r} -subset_R7 <- new_generic("R7_subset", signature = c("object", "row", "column")) +subset_R7 <- new_generic("R7_subset", dispatch_args = c("object", "row", "column")) method(subset_R7, list(annotated_df, "integer", "integer")) <- function(object, row, column, ...) { data <- object@.data[row, column] diff --git a/vignettes/performance.Rmd b/vignettes/performance.Rmd index e12282c9..6c18c122 100644 --- a/vignettes/performance.Rmd +++ b/vignettes/performance.Rmd @@ -27,7 +27,7 @@ number <- new_class("number", parent = "numeric", constructor = function(x) new_ x <- text("hi") y <- number(1) -foo_R7 <- new_generic("foo_R7", signature = "x") +foo_R7 <- new_generic("foo_R7", dispatch_args = "x") method(foo_R7, "text") <- function(x, ...) paste0(x, "-foo") foo_s3 <- function(x, ...) { @@ -48,7 +48,7 @@ setMethod("foo_s4", c("text"), function(x, ...) paste0(x, "-foo")) # Measure performance of single dispatch bench::mark(foo_R7(x), foo_s3(x), foo_s4(x)) -bar_R7 <- new_generic("bar_R7", signature = c("x", "y")) +bar_R7 <- new_generic("bar_R7", dispatch_args = c("x", "y")) method(bar_R7, list("text", "number")) <- function(x, y, ...) paste0(x, "-", y, "-bar") setGeneric("bar_s4", function(x, y, ...) standardGeneric("bar_s4")) @@ -96,11 +96,11 @@ bench::press( x <- do.call(cls, list("hi")) # Define a generic and a method for the last class (best case scenario) - foo_R7 <- new_generic("foo_R7", signature = "x") + foo_R7 <- new_generic("foo_R7", dispatch_args = "x") method(foo_R7, cls) <- function(x, ...) paste0(x, "-foo") # Define a generic and a method for the first class (worst case scenario) - foo2_R7 <- new_generic("foo2_R7", signature = "x") + foo2_R7 <- new_generic("foo2_R7", dispatch_args = "x") method(foo2_R7, R7_object) <- function(x, ...) paste0(x, "-foo") bench::mark( @@ -136,11 +136,11 @@ bench::press( y <- do.call(cls, list("ho")) # Define a generic and a method for the last class (best case scenario) - foo_R7 <- new_generic("foo_R7", signature = c("x", "y")) + foo_R7 <- new_generic("foo_R7", dispatch_args = c("x", "y")) method(foo_R7, list(cls, cls)) <- function(x, y, ...) paste0(x, y, "-foo") # Define a generic and a method for the first class (worst case scenario) - foo2_R7 <- new_generic("foo2_R7", signature = c("x", "y")) + foo2_R7 <- new_generic("foo2_R7", dispatch_args = c("x", "y")) method(foo2_R7, list(R7_object, R7_object)) <- function(x, y, ...) paste0(x, y, "-foo") bench::mark( From 6799ade7fde31d4c497e0130cb2925407bc5a8c4 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 11 Jan 2022 13:07:01 -0600 Subject: [PATCH 02/15] Improving handling of non-dispatched arguments Now all non-dispatched arguments are passed through to the method as is. ... no longer has special handling, except as it pertains to method compatibility --- R/generic.R | 22 ++++++++--- R/method.R | 14 +++---- src/code.c | 35 ++++++------------ tests/testthat/_snaps/method.md | 18 --------- tests/testthat/test-generic.R | 25 +++++++------ tests/testthat/test-method.R | 65 ++------------------------------- 6 files changed, 51 insertions(+), 128 deletions(-) diff --git a/R/generic.R b/R/generic.R index 66ed5998..bd182ee4 100644 --- a/R/generic.R +++ b/R/generic.R @@ -53,12 +53,11 @@ new_generic <- function(name, fun = NULL, dispatch_args = NULL) { check_generic(fun) dispatch_args <- guess_dispatch_args(fun) } else { - dispatch_args <- check_dispatch_args(dispatch_args) - # For now, ensure all generics have ... in dispatch_args - dispatch_args <- union(dispatch_args, "...") + dispatch_args <- check_dispatch_args(dispatch_args, fun) if (is.null(fun)) { - args <- setNames(lapply(dispatch_args, function(i) quote(expr = )), dispatch_args) + args <- c(dispatch_args, "...") + args <- setNames(lapply(args, function(i) quote(expr = )), args) fun <- make_function(args, quote(method_call()), topenv(environment())) } } @@ -69,16 +68,27 @@ new_generic <- function(name, fun = NULL, dispatch_args = NULL) { guess_dispatch_args <- function(fun) { formals <- formals(fun) is_required <- vlapply(formals, identical, quote(expr = )) - names(formals[is_required]) + setdiff(names(formals[is_required]), "...") } -check_dispatch_args <- function(dispatch_args) { +check_dispatch_args <- function(dispatch_args, fun = NULL) { if (!is.character(dispatch_args)) { stop("`dispatch_args` must be a character vector", call. = FALSE) } if (length(dispatch_args) == 0) { stop("`dispatch_args` must have at least one component", call. = FALSE) } + if ("..." %in% dispatch_args) { + stop("Can't dispatch on `...`", call. = FALSE) + } + + if (!is.null(fun)) { + args <- names(formals(fun)) + if (!identical(dispatch_args, args[seq_along(dispatch_args)])) { + stop("`dispatch_args` must be a prefix of the generic arguments") + } + } + dispatch_args } diff --git a/R/method.R b/R/method.R index bcb46fd2..8dbab324 100644 --- a/R/method.R +++ b/R/method.R @@ -153,19 +153,17 @@ method_compatible <- function(method, generic) { return() } - for (i in seq_len(length(generic_formals) - 1)) { + for (i in seq_len(length(generic_formals))) { + if (names(generic_formals[i]) == "...") { + # Method doesn't have to have ... even if generic does + next + } + if (!identical(generic_formals[i], method_formals[i])) { stop(sprintf("`method` must be consistent with %s.\n- Argument %i in generic %s\n- Argument %i in method %s", generic@name, i, arg_to_string(generic_formals[i]), i, arg_to_string(method_formals[i])), call. = FALSE) } } - if ("..." %in% names(generic_formals) && !"..." %in% names(method_formals)) { - stop(sprintf("`method` must be consistent with %s.\n- `generic` has `...`\n- `method` does not have `...`", generic@name), call. = FALSE) - } - - if (!"..." %in% names(generic_formals) && "..." %in% names(method_formals)) { - stop(sprintf("`method` must be consistent with %s.\n- `generic` does not have `...`\n- `method` has `...`", generic@name), call. = FALSE) - } TRUE } diff --git a/src/code.c b/src/code.c index f2f7654a..1b3d45e0 100644 --- a/src/code.c +++ b/src/code.c @@ -116,20 +116,12 @@ void R7_method_lookup_error(SEXP generic, SEXP signature, SEXP envir) { SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { int n_protect = 0; - // Get the signature, the names of arguments to use for dispatch - SEXP gen_signature_args = Rf_getAttrib(generic, Rf_install("dispatch_args")); - - // Every generic signature has `...` as the last arg, which we want to ignore. - R_xlen_t gen_signature_len = Rf_xlength(gen_signature_args); - - Rboolean has_dots = strcmp(CHAR(STRING_ELT(gen_signature_args, gen_signature_len - 1)), "...") == 0; - - if (has_dots) { - --gen_signature_len; - } + // Get the names of arguments to use for dispatch + SEXP dispatch_args = Rf_getAttrib(generic, Rf_install("dispatch_args")); + R_xlen_t n_dispatch = Rf_xlength(dispatch_args); // Allocate a list to store the classes for the arguments - SEXP signature_classes = PROTECT(Rf_allocVector(VECSXP, gen_signature_len)); + SEXP signature_classes = PROTECT(Rf_allocVector(VECSXP, n_dispatch)); ++n_protect; // Allocate a pairlist to hold the argument promises when we do the call to the method @@ -137,11 +129,11 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { ++n_protect; SEXP tail = args; - // For each of the arguments in the signature - for (R_xlen_t i = 0; i < gen_signature_len; ++i) { + // For each of the arguments used fo dispatch + for (R_xlen_t i = 0; i < n_dispatch; ++i) { // Lookup the promise for that argument in the environment - SEXP name = Rf_install(CHAR(STRING_ELT(gen_signature_args, i))); + SEXP name = Rf_install(CHAR(STRING_ELT(dispatch_args, i))); SEXP arg = Rf_findVar(name, envir); // Most of the time this should be a promise @@ -179,15 +171,10 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { tail = CDR(tail); } - - // We only need to add the dots to our arguments if the generic has dots and - // something was passed in them. Otherwise they are `R_MissingArg` and we - // don't need to. - if (has_dots) { - SEXP dots = Rf_findVar(R_DotsSymbol, envir); - if (dots != R_MissingArg) { - SETCDR(tail, dots); - } + // Now we add the remaining arguments from the call + R_xlen_t n_args = Rf_length(call) - 1; + for (R_xlen_t i = n_dispatch; i < n_args; ++i) { + SETCDR(tail, Rf_nthcdr(call, i + 1)); } // The head of args is always R_NilValue, so we just want the tail diff --git a/tests/testthat/_snaps/method.md b/tests/testthat/_snaps/method.md index 04cae629..cb0a4465 100644 --- a/tests/testthat/_snaps/method.md +++ b/tests/testthat/_snaps/method.md @@ -25,12 +25,6 @@ - Argument 1 in generic is `x = ` - Argument 1 in method is `y = ` ---- - - `method` must be consistent with foo. - - `generic` has `...` - - `method` does not have `...` - --- `method` must be consistent with foo. @@ -43,24 +37,12 @@ - Argument 1 in generic is `x = ` - Argument 1 in method is `y = ` ---- - - `method` must be consistent with bar. - - `generic` has `...` - - `method` does not have `...` - --- `method` must be consistent with bar. - Argument 2 in generic is `y = ` - Argument 2 in method is `y = NULL` -# method compatible verifies that if a generic does not have dots the method should not have dots - - `method` must be consistent with foo. - - `generic` does not have `...` - - `method` has `...` - # method lookup fails with an informative message for single classes Can't find method for generic `foo()` with classes: diff --git a/tests/testthat/test-generic.R b/tests/testthat/test-generic.R index 72366c98..66eeae9a 100644 --- a/tests/testthat/test-generic.R +++ b/tests/testthat/test-generic.R @@ -4,24 +4,27 @@ test_that("new_generic needs fun or dispatch_args", { test_that("dispatch_args overrules derived", { g <- new_generic("g", function(x, y, ...) method_call()) - expect_equal(g@dispatch_args, c("x", "y", "...")) + expect_equal(g@dispatch_args, c("x", "y")) g <- new_generic("g", function(x, y, ...) method_call(), dispatch_args = "x") - expect_equal(g@dispatch_args, c("x", "...")) + expect_equal(g@dispatch_args, "x") }) -test_that("generics pass ... to methods, and methods can define additional arguments on basic types", { +test_that("derived fun always includes ...", { + g <- new_generic("g", dispatch_args = "x") + expect_equal(names(formals(g)), c("x", "...")) +}) + +test_that("generics pass ... to methods, and methods can define additional arguments", { foo <- new_generic("foo", dispatch_args = "x") - new_method(foo, "character", function(x, sep = "-", ...) paste0("foo", sep, x)) + # base type + new_method(foo, "character", function(x, sep = "-") paste0("foo", sep, x)) expect_equal(foo("bar"), "foo-bar") expect_equal(foo("bar", sep = "/"), "foo/bar") -}) - -test_that("generics pass ... to methods, and methods can define additional arguments on R7 objects", { - foo <- new_generic("foo", dispatch_args = "x") - new_method(foo, "text", function(x, sep = "-", ...) paste0("foo", sep, x)) + # R7 + new_method(foo, "text", function(x, sep = "-") paste0("foo", sep, x)) expect_equal(foo(text("bar")), "foo-bar") expect_equal(foo(text("bar"), sep = "/"), "foo/bar") }) @@ -30,8 +33,8 @@ test_that("guesses dispatch_args from required arguments", { expect_equal(guess_dispatch_args(function() {}), NULL) expect_equal(guess_dispatch_args(function(x) {}), "x") expect_equal(guess_dispatch_args(function(x, y) {}), c("x", "y")) - expect_equal(guess_dispatch_args(function(x, y, ...) {}), c("x", "y", "...")) - expect_equal(guess_dispatch_args(function(x, ..., y = 1) {}), c("x", "...")) + expect_equal(guess_dispatch_args(function(x, y, ...) {}), c("x", "y")) + expect_equal(guess_dispatch_args(function(x, ..., y = 1) {}), c("x")) }) test_that("check_dispatch_args() produces informative errors", { diff --git a/tests/testthat/test-method.R b/tests/testthat/test-method.R index db93bb3f..43e1f17a 100644 --- a/tests/testthat/test-method.R +++ b/tests/testthat/test-method.R @@ -206,73 +206,16 @@ test_that("method_compatible returns TRUE if the functions are compatible", { test_that("method_compatible throws errors if the functions are not compatible", { foo <- new_generic("foo", dispatch_args = "x") - # Different argument names - expect_snapshot_error( - method_compatible( - function(y, ...) y, - foo - ) - ) - - # No dots in method - expect_snapshot_error( - method_compatible( - function(x) x, - foo - ) - ) - + expect_snapshot_error(method_compatible(function(y) {}, foo)) # Different default values - expect_snapshot_error( - method_compatible( - function(x = "foo", ...) x, - foo - ) - ) + expect_snapshot_error(method_compatible(function(x = "foo") {}, foo)) bar <- new_generic("bar", dispatch_args = c("x", "y")) - # Arguments in wrong order - expect_snapshot_error( - method_compatible( - function(y, x, ...) x, - bar - ) - ) - - # No dots in method - expect_snapshot_error( - method_compatible( - function(x, y) x, - bar - ) - ) - + expect_snapshot_error(method_compatible(function(y, x, ...) {}, bar)) # Different default values - expect_snapshot_error( - method_compatible( - function(x, y = NULL) x, - bar - ) - ) -}) - -test_that("method compatible verifies that if a generic does not have dots the method should not have dots", { - foo <- new_generic("foo", function(x) method_call()) - - expect_true( - method_compatible( - function(x) x, - foo - ) - ) - expect_snapshot_error( - method_compatible( - function(x, ...) x, - foo - ) - ) + expect_snapshot_error(method_compatible(function(x, y = NULL) {}, bar)) }) test_that("method lookup fails with an informative message for single classes", { From a403224b0c141796e9ac40eaad68bd0ce8c7cb63 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 12 Jan 2022 14:03:51 -0600 Subject: [PATCH 03/15] Pass arguments correctly --- src/code.c | 97 ++++++++++++++------------------- tests/testthat/_snaps/method.md | 2 +- tests/testthat/test-generic.R | 4 +- 3 files changed, 43 insertions(+), 60 deletions(-) diff --git a/src/code.c b/src/code.c index 1b3d45e0..2205250e 100644 --- a/src/code.c +++ b/src/code.c @@ -116,82 +116,65 @@ void R7_method_lookup_error(SEXP generic, SEXP signature, SEXP envir) { SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { int n_protect = 0; - // Get the names of arguments to use for dispatch + // Get the number of arguments to the generic + R_xlen_t n_args = Rf_xlength(FORMALS(generic)); + // And how many are used for dispatch SEXP dispatch_args = Rf_getAttrib(generic, Rf_install("dispatch_args")); R_xlen_t n_dispatch = Rf_xlength(dispatch_args); // Allocate a list to store the classes for the arguments - SEXP signature_classes = PROTECT(Rf_allocVector(VECSXP, n_dispatch)); + SEXP dispatch_classes = PROTECT(Rf_allocVector(VECSXP, n_dispatch)); ++n_protect; - // Allocate a pairlist to hold the argument promises when we do the call to the method - SEXP args = PROTECT(Rf_cons(R_NilValue, R_NilValue)); + // Allocate a pairlist to hold the arguments for when we call the method + SEXP mcall = PROTECT(Rf_lcons(R_NilValue, R_NilValue)); ++n_protect; - SEXP tail = args; + SEXP tail = mcall; - // For each of the arguments used fo dispatch - for (R_xlen_t i = 0; i < n_dispatch; ++i) { + // For each of the arguments to the generic + for (R_xlen_t i = 0; i < n_args; ++i) { - // Lookup the promise for that argument in the environment - SEXP name = Rf_install(CHAR(STRING_ELT(dispatch_args, i))); + // Find its name and look up its value (a promise) + SEXP name = TAG(Rf_nthcdr(FORMALS(generic), i)); SEXP arg = Rf_findVar(name, envir); - // Most of the time this should be a promise - if (TYPEOF(arg) == PROMSXP) { - - // We first want to duplicate the existing promise - SEXP new_promise = PROTECT(Rf_duplicate(arg)); - - // Then evaluate the original promise so we can lookup its class - SEXP val = PROTECT(Rf_eval(arg, envir)); - - // And set the value of the new promise to that of the evaluated one, so - // we don't evaluate it twice in the method body. - SET_PRVALUE(new_promise, val); - - // We can then add our new promise to our argument list - SETCDR(tail, Rf_cons(new_promise, R_NilValue)); - - // We need to call `R7::object_class()`, as not every object has a class - // attribute, some are created dynamically. - SEXP klass = PROTECT(object_class_(val, envir)); - - // Now that we have the classes for the argument we can add them to the signature classes - SET_VECTOR_ELT(signature_classes, i, klass); - - UNPROTECT(3); - } - // but the bytecode compiler sometimes inlines literals, which we handle - // here - else { - SETCDR(tail, Rf_cons(arg, R_NilValue)); + if (i < n_dispatch) { + if (PRCODE(arg) != R_MissingArg) { + // Evaluate the original promise so we can look up its class + SEXP val = PROTECT(Rf_eval(arg, envir)); + // And update the value of the promise to avoid evaluating it + // again in the method body + SET_PRVALUE(arg, val); + // Then add to arguments to method call + SETCDR(tail, Rf_cons(arg, R_NilValue)); + + // We need to call `R7::object_class()`, as not every object has a class + // attribute, some are created dynamically. + SEXP klass = PROTECT(object_class_(val, envir)); + + // Now that we have the classes for the argument we can add them to the signature classes + SET_VECTOR_ELT(dispatch_classes, i, klass); + UNPROTECT(2); + } else { + SETCDR(tail, Rf_cons(name, R_NilValue)); + SET_VECTOR_ELT(dispatch_classes, i, Rf_mkString("MISSING")); + } + } else { + SETCDR(tail, Rf_cons(name, R_NilValue)); } - - // Move the pointer forward for the next iteration tail = CDR(tail); } - // Now we add the remaining arguments from the call - R_xlen_t n_args = Rf_length(call) - 1; - for (R_xlen_t i = n_dispatch; i < n_args; ++i) { - SETCDR(tail, Rf_nthcdr(call, i + 1)); - } - - // The head of args is always R_NilValue, so we just want the tail - args = CDR(args); - - // Now that we have retrieved all the classes, we can look up what method to call. - SEXP m = method_(generic, signature_classes, R_NilValue); - - // If no method found, throw an error + // Now that we have all the classes, we can look up what method to call + SEXP m = method_(generic, dispatch_classes, R_NilValue); if (m == R_NilValue) { - R7_method_lookup_error(generic, signature_classes, envir); + R7_method_lookup_error(generic, dispatch_classes, envir); } + SETCAR(mcall, m); - // And then actually call it. - SEXP res = Rf_applyClosure(call, m, args, envir, R_NilValue); + // And then call it + SEXP res = Rf_eval(mcall, envir); UNPROTECT(n_protect); - return res; } diff --git a/tests/testthat/_snaps/method.md b/tests/testthat/_snaps/method.md index cb0a4465..899f9f50 100644 --- a/tests/testthat/_snaps/method.md +++ b/tests/testthat/_snaps/method.md @@ -53,7 +53,7 @@ Can't find method for generic `foo()` with classes: - x: - - y: <> + - y: # method lookup fails with an informative message for multiple classes diff --git a/tests/testthat/test-generic.R b/tests/testthat/test-generic.R index 66eeae9a..eb1534ef 100644 --- a/tests/testthat/test-generic.R +++ b/tests/testthat/test-generic.R @@ -19,12 +19,12 @@ test_that("generics pass ... to methods, and methods can define additional argum foo <- new_generic("foo", dispatch_args = "x") # base type - new_method(foo, "character", function(x, sep = "-") paste0("foo", sep, x)) + method(foo, "character") <- function(x, sep = "-") paste0("foo", sep, x) expect_equal(foo("bar"), "foo-bar") expect_equal(foo("bar", sep = "/"), "foo/bar") # R7 - new_method(foo, "text", function(x, sep = "-") paste0("foo", sep, x)) + method(foo, "text") <- function(x, sep = "-") paste0("foo", sep, x) expect_equal(foo(text("bar")), "foo-bar") expect_equal(foo(text("bar"), sep = "/"), "foo/bar") }) From 505cac01959ec9cfb23395c2fc8e83aa4d52c39f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 12 Jan 2022 14:29:53 -0600 Subject: [PATCH 04/15] Common file naming scheme for dispatch code --- R/dispatch.R | 11 ++++++++ R/method.R | 12 -------- src/{code.c => dispatch.c} | 0 tests/testthat/_snaps/dispatch.md | 18 ++++++++++++ tests/testthat/_snaps/method.md | 18 ------------ tests/testthat/test-dispatch.R | 46 +++++++++++++++++++++++++++++++ tests/testthat/test-generic.R | 14 ---------- tests/testthat/test-method.R | 30 -------------------- 8 files changed, 75 insertions(+), 74 deletions(-) create mode 100644 R/dispatch.R rename src/{code.c => dispatch.c} (100%) create mode 100644 tests/testthat/_snaps/dispatch.md create mode 100644 tests/testthat/test-dispatch.R diff --git a/R/dispatch.R b/R/dispatch.R new file mode 100644 index 00000000..24ab560e --- /dev/null +++ b/R/dispatch.R @@ -0,0 +1,11 @@ +method_lookup_error <- function(name, args, signatures) { + args <- setdiff(args, "...") + types <- paste0("- ", args, ": ", vcapply(signatures, fmt_classes), collapse = "\n") + stop(sprintf("Can't find method for generic `%s()` with classes:\n%s", name, types), call. = FALSE) +} + +#' Lookup the R7 method for the current generic and call it. +#' @export +method_call <- function() { + .Call(method_call_, sys.call(-1), sys.function(-1), sys.frame(-1)) +} diff --git a/R/method.R b/R/method.R index 8dbab324..030d1570 100644 --- a/R/method.R +++ b/R/method.R @@ -261,18 +261,6 @@ as_generic <- function(generic) { generic } -method_lookup_error <- function(name, args, signatures) { - args <- setdiff(args, "...") - types <- paste0("- ", args, ": ", vcapply(signatures, fmt_classes), collapse = "\n") - stop(sprintf("Can't find method for generic `%s()` with classes:\n%s", name, types), call. = FALSE) -} - -#' Lookup the R7 method for the current generic and call it. -#' @export -method_call <- function() { - .Call(method_call_, sys.call(-1), sys.function(-1), sys.frame(-1)) -} - #' @export print.R7_method <- function(x, ...) { method_signature <- method_signature(x@signature) diff --git a/src/code.c b/src/dispatch.c similarity index 100% rename from src/code.c rename to src/dispatch.c diff --git a/tests/testthat/_snaps/dispatch.md b/tests/testthat/_snaps/dispatch.md new file mode 100644 index 00000000..134cb76b --- /dev/null +++ b/tests/testthat/_snaps/dispatch.md @@ -0,0 +1,18 @@ +# method lookup fails with an informative message for single classes + + Can't find method for generic `foo()` with classes: + - x: + - y: + +--- + + Can't find method for generic `foo()` with classes: + - x: + - y: + +# method lookup fails with an informative message for multiple classes + + Can't find method for generic `foo()` with classes: + - x: , , + - y: , + diff --git a/tests/testthat/_snaps/method.md b/tests/testthat/_snaps/method.md index 899f9f50..20e4fd93 100644 --- a/tests/testthat/_snaps/method.md +++ b/tests/testthat/_snaps/method.md @@ -43,24 +43,6 @@ - Argument 2 in generic is `y = ` - Argument 2 in method is `y = NULL` -# method lookup fails with an informative message for single classes - - Can't find method for generic `foo()` with classes: - - x: - - y: - ---- - - Can't find method for generic `foo()` with classes: - - x: - - y: - -# method lookup fails with an informative message for multiple classes - - Can't find method for generic `foo()` with classes: - - x: , , - - y: , - # R7_method printing Code diff --git a/tests/testthat/test-dispatch.R b/tests/testthat/test-dispatch.R new file mode 100644 index 00000000..80788ed0 --- /dev/null +++ b/tests/testthat/test-dispatch.R @@ -0,0 +1,46 @@ + +test_that("substitute() works for multiple dispatch method calls like S3", { + foo <- new_generic("foo", dispatch_args = c("x", "y")) + + new_method(foo, "character", function(x, y, ...) c(substitute(x), substitute(y))) + + bar <- "blah" + baz <- "bloo" + expect_equal(foo(bar, baz), c(as.symbol("bar"), as.symbol("baz"))) +}) + + +test_that("generics pass ... to methods, and methods can define additional arguments", { + foo <- new_generic("foo", dispatch_args = "x") + + # base type + method(foo, "character") <- function(x, sep = "-") paste0("foo", sep, x) + expect_equal(foo("bar"), "foo-bar") + expect_equal(foo("bar", sep = "/"), "foo/bar") + + # R7 + method(foo, "text") <- function(x, sep = "-") paste0("foo", sep, x) + expect_equal(foo(text("bar")), "foo-bar") + expect_equal(foo(text("bar"), sep = "/"), "foo/bar") +}) + + +test_that("method lookup fails with an informative message for single classes", { + foo <- new_generic(name="foo", dispatch_args = c("x", "y")) + method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) + expect_snapshot_error( + foo(TRUE, list()) + ) + + expect_snapshot_error( + foo(TRUE) + ) +}) + +test_that("method lookup fails with an informative message for multiple classes", { + foo <- new_generic(name="foo", dispatch_args = c("x", "y")) + method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) + expect_snapshot_error( + foo(tibble::tibble(), .POSIXct(double())) + ) +}) diff --git a/tests/testthat/test-generic.R b/tests/testthat/test-generic.R index eb1534ef..844be226 100644 --- a/tests/testthat/test-generic.R +++ b/tests/testthat/test-generic.R @@ -15,20 +15,6 @@ test_that("derived fun always includes ...", { expect_equal(names(formals(g)), c("x", "...")) }) -test_that("generics pass ... to methods, and methods can define additional arguments", { - foo <- new_generic("foo", dispatch_args = "x") - - # base type - method(foo, "character") <- function(x, sep = "-") paste0("foo", sep, x) - expect_equal(foo("bar"), "foo-bar") - expect_equal(foo("bar", sep = "/"), "foo/bar") - - # R7 - method(foo, "text") <- function(x, sep = "-") paste0("foo", sep, x) - expect_equal(foo(text("bar")), "foo-bar") - expect_equal(foo(text("bar"), sep = "/"), "foo/bar") -}) - test_that("guesses dispatch_args from required arguments", { expect_equal(guess_dispatch_args(function() {}), NULL) expect_equal(guess_dispatch_args(function(x) {}), "x") diff --git a/tests/testthat/test-method.R b/tests/testthat/test-method.R index 43e1f17a..a4964370 100644 --- a/tests/testthat/test-method.R +++ b/tests/testthat/test-method.R @@ -151,16 +151,6 @@ test_that("substitute() works for single dispatch method calls like S3", { expect_equal(foo(bar), as.symbol("bar")) }) -test_that("substitute() works for multiple dispatch method calls like S3", { - foo <- new_generic("foo", dispatch_args = c("x", "y")) - - new_method(foo, "character", function(x, y, ...) c(substitute(x), substitute(y))) - - bar <- "blah" - baz <- "bloo" - expect_equal(foo(bar, baz), c(as.symbol("bar"), as.symbol("baz"))) -}) - test_that("method_compatible returns TRUE if the functions are compatible", { foo <- new_generic("foo", dispatch_args = "x") @@ -218,26 +208,6 @@ test_that("method_compatible throws errors if the functions are not compatible", expect_snapshot_error(method_compatible(function(x, y = NULL) {}, bar)) }) -test_that("method lookup fails with an informative message for single classes", { - foo <- new_generic(name="foo", dispatch_args = c("x", "y")) - method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) - expect_snapshot_error( - foo(TRUE, list()) - ) - - expect_snapshot_error( - foo(TRUE) - ) -}) - -test_that("method lookup fails with an informative message for multiple classes", { - foo <- new_generic(name="foo", dispatch_args = c("x", "y")) - method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) - expect_snapshot_error( - foo(tibble::tibble(), .POSIXct(double())) - ) -}) - test_that("R7_method printing", { foo <- new_generic(name="foo", dispatch_args = c("x", "y")) method(foo, list(text, "integer")) <- function(x, y, ...) paste0("bar:", x, y) From 5f1aa785b41ee1a7c0381db46bc8aa06604e737f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 12 Jan 2022 14:34:20 -0600 Subject: [PATCH 05/15] Streamline tests --- tests/testthat/_snaps/dispatch.md | 12 +++++--- tests/testthat/test-dispatch.R | 46 ++++++++----------------------- 2 files changed, 19 insertions(+), 39 deletions(-) diff --git a/tests/testthat/_snaps/dispatch.md b/tests/testthat/_snaps/dispatch.md index 134cb76b..5620be07 100644 --- a/tests/testthat/_snaps/dispatch.md +++ b/tests/testthat/_snaps/dispatch.md @@ -1,16 +1,20 @@ -# method lookup fails with an informative message for single classes +# generics pass ... to methods + + unused argument (baz = "/") + +# method lookup fails with informative messages Can't find method for generic `foo()` with classes: - x: - - y: + - y: --- Can't find method for generic `foo()` with classes: - x: - - y: + - y: -# method lookup fails with an informative message for multiple classes +--- Can't find method for generic `foo()` with classes: - x: , , diff --git a/tests/testthat/test-dispatch.R b/tests/testthat/test-dispatch.R index 80788ed0..e39fa87a 100644 --- a/tests/testthat/test-dispatch.R +++ b/tests/testthat/test-dispatch.R @@ -1,46 +1,22 @@ - -test_that("substitute() works for multiple dispatch method calls like S3", { - foo <- new_generic("foo", dispatch_args = c("x", "y")) - - new_method(foo, "character", function(x, y, ...) c(substitute(x), substitute(y))) - - bar <- "blah" - baz <- "bloo" - expect_equal(foo(bar, baz), c(as.symbol("bar"), as.symbol("baz"))) +test_that("can substitute() dispatch args", { + foo <- new_generic("foo", dispatch_args = "x") + method(foo, "character") <- function(x, ...) substitute(x) + expect_equal(foo(letters), quote(letters)) }) - -test_that("generics pass ... to methods, and methods can define additional arguments", { +test_that("generics pass ... to methods", { foo <- new_generic("foo", dispatch_args = "x") - # base type method(foo, "character") <- function(x, sep = "-") paste0("foo", sep, x) expect_equal(foo("bar"), "foo-bar") expect_equal(foo("bar", sep = "/"), "foo/bar") - - # R7 - method(foo, "text") <- function(x, sep = "-") paste0("foo", sep, x) - expect_equal(foo(text("bar")), "foo-bar") - expect_equal(foo(text("bar"), sep = "/"), "foo/bar") + expect_snapshot_error(foo("bar", baz = "/")) }) - -test_that("method lookup fails with an informative message for single classes", { - foo <- new_generic(name="foo", dispatch_args = c("x", "y")) - method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) - expect_snapshot_error( - foo(TRUE, list()) - ) - - expect_snapshot_error( - foo(TRUE) - ) -}) - -test_that("method lookup fails with an informative message for multiple classes", { - foo <- new_generic(name="foo", dispatch_args = c("x", "y")) +test_that("method lookup fails with informative messages", { + foo <- new_generic("foo", dispatch_args = c("x", "y")) method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) - expect_snapshot_error( - foo(tibble::tibble(), .POSIXct(double())) - ) + expect_snapshot_error(foo(TRUE)) + expect_snapshot_error(foo(TRUE, list())) + expect_snapshot_error(foo(tibble::tibble(), .POSIXct(double()))) }) From 33b0dc758b966fc97f9fb6a7951f0d8400f02114 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 12 Jan 2022 14:38:36 -0600 Subject: [PATCH 06/15] Test dispatch args evaluated once --- tests/testthat/test-dispatch.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/testthat/test-dispatch.R b/tests/testthat/test-dispatch.R index e39fa87a..9b1d8ff5 100644 --- a/tests/testthat/test-dispatch.R +++ b/tests/testthat/test-dispatch.R @@ -4,6 +4,20 @@ test_that("can substitute() dispatch args", { expect_equal(foo(letters), quote(letters)) }) +test_that("dispatched arguments are evaluated once", { + counter <- local({ + i <- 0 + function() { + i <<- i + 1 + i + } + }) + + f <- new_generic("f", dispatch_args = "x") + method(f, "numeric") <- function(x) x + expect_equal(f(counter()), 1) +}) + test_that("generics pass ... to methods", { foo <- new_generic("foo", dispatch_args = "x") From d0b41d03d6cd238e55971975e1c333dee1c4396f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 12 Jan 2022 14:42:24 -0600 Subject: [PATCH 07/15] Name arguments --- src/dispatch.c | 4 +++- tests/testthat/test-dispatch.R | 6 ++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/src/dispatch.c b/src/dispatch.c index 2205250e..05b89979 100644 --- a/src/dispatch.c +++ b/src/dispatch.c @@ -160,7 +160,9 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { SET_VECTOR_ELT(dispatch_classes, i, Rf_mkString("MISSING")); } } else { - SETCDR(tail, Rf_cons(name, R_NilValue)); + SEXP arg_wrap = Rf_cons(name, R_NilValue); + SET_TAG(arg_wrap, name); + SETCDR(tail, arg_wrap); } tail = CDR(tail); } diff --git a/tests/testthat/test-dispatch.R b/tests/testthat/test-dispatch.R index 9b1d8ff5..d138bf69 100644 --- a/tests/testthat/test-dispatch.R +++ b/tests/testthat/test-dispatch.R @@ -27,6 +27,12 @@ test_that("generics pass ... to methods", { expect_snapshot_error(foo("bar", baz = "/")) }) +test_that("generics pass extra args to methods", { + foo <- new_generic("foo", function(x, ..., z = 1) method_call()) + method(foo, "character") <- function(x, ..., z = 1) z + expect_equal(foo("x", z = 3), 3) +}) + test_that("method lookup fails with informative messages", { foo <- new_generic("foo", dispatch_args = c("x", "y")) method(foo, c("character", "integer")) <- function(x, y, ...) paste0("bar:", x, y) From 25c20f7269bbdb4ba3774b2897265676d7b7b677 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 12 Jan 2022 14:43:45 -0600 Subject: [PATCH 08/15] Expand substitute() tests --- tests/testthat/test-dispatch.R | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-dispatch.R b/tests/testthat/test-dispatch.R index d138bf69..c2d5c80d 100644 --- a/tests/testthat/test-dispatch.R +++ b/tests/testthat/test-dispatch.R @@ -1,7 +1,14 @@ -test_that("can substitute() dispatch args", { - foo <- new_generic("foo", dispatch_args = "x") - method(foo, "character") <- function(x, ...) substitute(x) +test_that("can substitute() args", { + foo <- new_generic("foo", function(x, ..., z = 1) method_call()) + method(foo, "character") <- function(x, ..., z = 1) substitute(x) expect_equal(foo(letters), quote(letters)) + + method(foo, "character") <- function(x, ..., z = 1, y) substitute(y) + expect_equal(foo("x", y = letters), quote(letters)) + + # Doesn't work currently + # method(foo, "character") <- function(x, ..., z = 1) substitute(z) + # expect_equal(foo("x", z = letters), quote(letters)) }) test_that("dispatched arguments are evaluated once", { From 03a9c83adf80a805ca7878078d51a1c5332226c3 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 12 Jan 2022 14:55:48 -0600 Subject: [PATCH 09/15] Test that we don't have UseMethod behaviour --- tests/testthat/test-dispatch.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/testthat/test-dispatch.R b/tests/testthat/test-dispatch.R index c2d5c80d..2797c7bc 100644 --- a/tests/testthat/test-dispatch.R +++ b/tests/testthat/test-dispatch.R @@ -11,6 +11,15 @@ test_that("can substitute() args", { # expect_equal(foo("x", z = letters), quote(letters)) }) +test_that("methods get values modified in the generic", { + foo <- new_generic("foo", function(x, y = 1) { + y <- 10 + method_call() + }) + method(foo, "character") <- function(x, y = 1) y + expect_equal(foo("x", 1), 10) +}) + test_that("dispatched arguments are evaluated once", { counter <- local({ i <- 0 From f2630a0fb4be9d9f75597b0cdc131b1346f9702d Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 12 Jan 2022 14:58:31 -0600 Subject: [PATCH 10/15] Simplify test --- tests/testthat/_snaps/dispatch.md | 2 +- tests/testthat/test-dispatch.R | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/testthat/_snaps/dispatch.md b/tests/testthat/_snaps/dispatch.md index 5620be07..4538d713 100644 --- a/tests/testthat/_snaps/dispatch.md +++ b/tests/testthat/_snaps/dispatch.md @@ -1,6 +1,6 @@ # generics pass ... to methods - unused argument (baz = "/") + unused argument (z = 2) # method lookup fails with informative messages diff --git a/tests/testthat/test-dispatch.R b/tests/testthat/test-dispatch.R index 2797c7bc..603039d4 100644 --- a/tests/testthat/test-dispatch.R +++ b/tests/testthat/test-dispatch.R @@ -37,10 +37,10 @@ test_that("dispatched arguments are evaluated once", { test_that("generics pass ... to methods", { foo <- new_generic("foo", dispatch_args = "x") - method(foo, "character") <- function(x, sep = "-") paste0("foo", sep, x) - expect_equal(foo("bar"), "foo-bar") - expect_equal(foo("bar", sep = "/"), "foo/bar") - expect_snapshot_error(foo("bar", baz = "/")) + method(foo, "character") <- function(x, y = 1) y + expect_equal(foo("x"), 1) + expect_equal(foo("x", y = 2), 2) + expect_snapshot_error(foo("x", z = 2)) }) test_that("generics pass extra args to methods", { From 032b15cc5f72743f8c506917ce1cdc21f1267d53 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 17 Jan 2022 15:53:38 -0600 Subject: [PATCH 11/15] Fix example --- R/generic.R | 4 +++- man/method_call.Rd | 2 +- man/new_generic.Rd | 4 +++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/R/generic.R b/R/generic.R index bd182ee4..fd286676 100644 --- a/R/generic.R +++ b/R/generic.R @@ -39,7 +39,9 @@ #' } #' sum(x) / length(x) #' } -#' method(mean2, "character") <- function(x, ...) {stop("Not supported")} +#' method(mean2, "character") <- function(x, ..., na.rm = TRUE) { +#' stop("Not supported") +#' } #' new_generic <- function(name, fun = NULL, dispatch_args = NULL) { if (is.null(dispatch_args) && is.null(fun)) { diff --git a/man/method_call.Rd b/man/method_call.Rd index bbcf0a1a..55aac11d 100644 --- a/man/method_call.Rd +++ b/man/method_call.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/method.R +% Please edit documentation in R/dispatch.R \name{method_call} \alias{method_call} \title{Lookup the R7 method for the current generic and call it.} diff --git a/man/new_generic.Rd b/man/new_generic.Rd index cde83b1e..57877c12 100644 --- a/man/new_generic.Rd +++ b/man/new_generic.Rd @@ -46,7 +46,9 @@ method(mean2, "numeric") <- function(x, ..., na.rm = TRUE) { } sum(x) / length(x) } -method(mean2, "character") <- function(x, ...) {stop("Not supported")} +method(mean2, "character") <- function(x, ..., na.rm = TRUE) { + stop("Not supported") +} } \seealso{ From cec5833bf138c827be33264af983135e3a06befe Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 18 Jan 2022 15:08:28 -0600 Subject: [PATCH 12/15] Updates from review --- R/generic.R | 31 +++++++++++---- R/method.R | 40 +++++++++++-------- man/new_generic.Rd | 9 ++++- src/dispatch.c | 25 ++++++------ tests/testthat/_snaps/generic.md | 12 ++++++ tests/testthat/_snaps/method.md | 50 +++++++++++++---------- tests/testthat/test-generic.R | 15 ++++--- tests/testthat/test-method.R | 68 ++++++++++---------------------- 8 files changed, 140 insertions(+), 110 deletions(-) diff --git a/R/generic.R b/R/generic.R index fd286676..4bb724f4 100644 --- a/R/generic.R +++ b/R/generic.R @@ -8,10 +8,16 @@ #' @param name The name of the generic. This should be the same as the object #' that you assign it to. #' @param dispatch_args A character vector providing the names of arguments to -#' dispatch on. If omitted, defaults to the required arguments of `fun`. +#' dispatch on. +#' +#' If `dispatch_args` are omitted, but `fun` is supplied, will default to the +#' arguments that appear before `...` in `fun`. If there are no dots, it will +#' default to the first argument. If both `fun` and `dispatch_args` are +#' supplied, the `dispatch_args` must appear at the start of `fun`'s formals. +#' #' @param fun An optional specification of the generic, which must call #' `method_call()` to dispatch to methods. This is usually generated -#' automatically from the `signature`, but you may want to supply it if +#' automatically from the `dispatch_args`, but you may want to supply it if #' you want to add additional required arguments, or perform some standardised #' computation in the generic. #' @seealso [new_external_generic()] to define a method for a generic @@ -69,8 +75,14 @@ new_generic <- function(name, fun = NULL, dispatch_args = NULL) { guess_dispatch_args <- function(fun) { formals <- formals(fun) - is_required <- vlapply(formals, identical, quote(expr = )) - setdiff(names(formals[is_required]), "...") + # all arguments before ... + if (length(formals) == 0) { + character() + } else if ("..." %in% names(formals)) { + names(formals)[seq_len(which(names(formals) == "...") - 1)] + } else { + names(formals)[[1]] + } } check_dispatch_args <- function(dispatch_args, fun = NULL) { @@ -85,9 +97,14 @@ check_dispatch_args <- function(dispatch_args, fun = NULL) { } if (!is.null(fun)) { - args <- names(formals(fun)) - if (!identical(dispatch_args, args[seq_along(dispatch_args)])) { - stop("`dispatch_args` must be a prefix of the generic arguments") + arg_names <- names(formals(fun)) + + if (!identical(dispatch_args, arg_names[seq_along(dispatch_args)])) { + stop("`dispatch_args` must be a prefix of the generic arguments", call. = FALSE) + } + + if ("..." %in% arg_names && arg_names[[length(dispatch_args) + 1]] != "...") { + stop("If present, ... must immediately follow the `dispatch_args`", call. = FALSE) } } diff --git a/R/method.R b/R/method.R index 030d1570..3c6dd978 100644 --- a/R/method.R +++ b/R/method.R @@ -136,31 +136,37 @@ next_method <- function() { method_impl(generic, signature, ignore = methods) } - -arg_to_string <- function(arg) { - if (is.na(names(arg)[[1]])) { - return("does not exist") - } - sprintf("is `%s = %s`", names(arg), deparse(arg[[1]])) -} - method_compatible <- function(method, generic) { generic_formals <- suppressWarnings(formals(args(generic))) - method_formals <- formals(method) - # This can happen for some primitive functions such as `[` if (length(generic_formals) == 0) { return() } - for (i in seq_len(length(generic_formals))) { - if (names(generic_formals[i]) == "...") { - # Method doesn't have to have ... even if generic does - next - } + method_formals <- formals(method) + generic_args <- names(generic_formals) + method_args <- names(method_formals) + + n_dispatch <- length(generic@dispatch_args) + has_dispatch <- length(method_formals) >= n_dispatch && + identical(method_args[1:n_dispatch], generic@dispatch_args) + if (!has_dispatch) { + stop("`method` doesn't match generic dispatch arg", call. = FALSE) + } + if ("..." %in% method_args && method_args[[n_dispatch + 1]] != "...") { + stop("... must immediately follow dispatch args", call. = FALSE) + } + empty_dispatch <- vlapply(method_formals[generic@dispatch_args], identical, quote(expr = )) + if (any(!empty_dispatch)) { + stop("Dispatch arguments must not have default values", call. = FALSE) + } - if (!identical(generic_formals[i], method_formals[i])) { - stop(sprintf("`method` must be consistent with %s.\n- Argument %i in generic %s\n- Argument %i in method %s", generic@name, i, arg_to_string(generic_formals[i]), i, arg_to_string(method_formals[i])), call. = FALSE) + extra_args <- setdiff(names(generic_formals), c(generic@dispatch_args, "...")) + for (arg in extra_args) { + if (!arg %in% method_args) { + warning(sprintf("Argument `%s` is missing from method", arg), call. = FALSE) + } else if (!identical(generic_formals[[arg]], method_formals[[arg]])) { + warning(sprintf("Default value is not the same as the generic\n- Generic: %s = %s\n- Method: %s = %s", arg, deparse1(generic_formals[[arg]]), arg, deparse1(method_formals[[arg]])), call. = FALSE) } } diff --git a/man/new_generic.Rd b/man/new_generic.Rd index 57877c12..fd2aef92 100644 --- a/man/new_generic.Rd +++ b/man/new_generic.Rd @@ -12,12 +12,17 @@ that you assign it to.} \item{fun}{An optional specification of the generic, which must call \code{method_call()} to dispatch to methods. This is usually generated -automatically from the \code{signature}, but you may want to supply it if +automatically from the \code{dispatch_args}, but you may want to supply it if you want to add additional required arguments, or perform some standardised computation in the generic.} \item{dispatch_args}{A character vector providing the names of arguments to -dispatch on. If omitted, defaults to the required arguments of \code{fun}.} +dispatch on. + +If \code{dispatch_args} are omitted, but \code{fun} is supplied, will default to the +arguments that appear before \code{...} in \code{fun}. If there are no dots, it will +default to the first argument. If both \code{fun} and \code{dispatch_args} are +supplied, the \code{dispatch_args} must appear at the start of \code{fun}'s formals.} } \description{ A generic function uses different implementations depending on the class diff --git a/src/dispatch.c b/src/dispatch.c index 05b89979..dbbd1fbd 100644 --- a/src/dispatch.c +++ b/src/dispatch.c @@ -117,7 +117,8 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { int n_protect = 0; // Get the number of arguments to the generic - R_xlen_t n_args = Rf_xlength(FORMALS(generic)); + SEXP formals = FORMALS(generic); + R_xlen_t n_args = Rf_xlength(formals); // And how many are used for dispatch SEXP dispatch_args = Rf_getAttrib(generic, Rf_install("dispatch_args")); R_xlen_t n_dispatch = Rf_xlength(dispatch_args); @@ -129,42 +130,42 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { // Allocate a pairlist to hold the arguments for when we call the method SEXP mcall = PROTECT(Rf_lcons(R_NilValue, R_NilValue)); ++n_protect; - SEXP tail = mcall; + SEXP mcall_tail = mcall; // For each of the arguments to the generic for (R_xlen_t i = 0; i < n_args; ++i) { // Find its name and look up its value (a promise) - SEXP name = TAG(Rf_nthcdr(FORMALS(generic), i)); + SEXP name = TAG(formals); SEXP arg = Rf_findVar(name, envir); if (i < n_dispatch) { if (PRCODE(arg) != R_MissingArg) { // Evaluate the original promise so we can look up its class - SEXP val = PROTECT(Rf_eval(arg, envir)); + SEXP val = Rf_eval(arg, R_EmptyEnv); // And update the value of the promise to avoid evaluating it // again in the method body SET_PRVALUE(arg, val); // Then add to arguments to method call - SETCDR(tail, Rf_cons(arg, R_NilValue)); + SETCDR(mcall_tail, Rf_cons(arg, R_NilValue)); // We need to call `R7::object_class()`, as not every object has a class // attribute, some are created dynamically. - SEXP klass = PROTECT(object_class_(val, envir)); - // Now that we have the classes for the argument we can add them to the signature classes - SET_VECTOR_ELT(dispatch_classes, i, klass); - UNPROTECT(2); + SET_VECTOR_ELT(dispatch_classes, i, object_class_(val, envir)); } else { - SETCDR(tail, Rf_cons(name, R_NilValue)); + SETCDR(mcall_tail, Rf_cons(name, R_NilValue)); SET_VECTOR_ELT(dispatch_classes, i, Rf_mkString("MISSING")); } } else { + // other arguments not used for dispatch SEXP arg_wrap = Rf_cons(name, R_NilValue); SET_TAG(arg_wrap, name); - SETCDR(tail, arg_wrap); + SETCDR(mcall_tail, arg_wrap); } - tail = CDR(tail); + + mcall_tail = CDR(mcall_tail); + formals = CDR(formals); } // Now that we have all the classes, we can look up what method to call diff --git a/tests/testthat/_snaps/generic.md b/tests/testthat/_snaps/generic.md index 7b2eadf9..88f479b8 100644 --- a/tests/testthat/_snaps/generic.md +++ b/tests/testthat/_snaps/generic.md @@ -12,6 +12,18 @@ check_dispatch_args(character()) Error `dispatch_args` must have at least one component + Code + check_dispatch_args("...") + Error + Can't dispatch on `...` + Code + check_dispatch_args("x", function(x, y, ...) { }) + Error + If present, ... must immediately follow the `dispatch_args` + Code + check_dispatch_args("y", function(x, ..., y) { }) + Error + `dispatch_args` must be a prefix of the generic arguments # R7_generic printing diff --git a/tests/testthat/_snaps/method.md b/tests/testthat/_snaps/method.md index 20e4fd93..c740d53e 100644 --- a/tests/testthat/_snaps/method.md +++ b/tests/testthat/_snaps/method.md @@ -19,29 +19,39 @@ Can't find method for generic `foo()` with classes: - x: -# method_compatible throws errors if the functions are not compatible +# method_compatible errors if the functions are not compatible - `method` must be consistent with foo. - - Argument 1 in generic is `x = ` - - Argument 1 in method is `y = ` - ---- - - `method` must be consistent with foo. - - Argument 1 in generic is `x = ` - - Argument 1 in method is `x = "foo"` - ---- - - `method` must be consistent with bar. - - Argument 1 in generic is `x = ` - - Argument 1 in method is `y = ` + Code + foo <- new_generic("foo", dispatch_args = "x") + method_compatible(function(y) { }, foo) + Error + `method` doesn't match generic dispatch arg + Code + method_compatible(function(x = "foo") { }, foo) + Error + Dispatch arguments must not have default values + Code + method_compatible(function(x, y, ...) { }, foo) + Error + ... must immediately follow dispatch args ---- +# method_compatible warn if default arguments don't match - `method` must be consistent with bar. - - Argument 2 in generic is `y = ` - - Argument 2 in method is `y = NULL` + Code + foo <- new_generic("foo", function(x, ..., z = 2, y = 1) method_call()) + method_compatible(function(x, ..., y = 1) { }, foo) + Warning + Argument `z` is missing from method + Output + [1] TRUE + Code + method_compatible(function(x, ..., y = 1, z = 1) { }, foo) + Warning + Default value is not the same as the generic + - Generic: z = 2 + - Method: z = 1 + Output + [1] TRUE # R7_method printing diff --git a/tests/testthat/test-generic.R b/tests/testthat/test-generic.R index 844be226..b864c550 100644 --- a/tests/testthat/test-generic.R +++ b/tests/testthat/test-generic.R @@ -6,7 +6,7 @@ test_that("dispatch_args overrules derived", { g <- new_generic("g", function(x, y, ...) method_call()) expect_equal(g@dispatch_args, c("x", "y")) - g <- new_generic("g", function(x, y, ...) method_call(), dispatch_args = "x") + g <- new_generic("g", function(x, ...) method_call(), dispatch_args = "x") expect_equal(g@dispatch_args, "x") }) @@ -15,18 +15,23 @@ test_that("derived fun always includes ...", { expect_equal(names(formals(g)), c("x", "...")) }) -test_that("guesses dispatch_args from required arguments", { - expect_equal(guess_dispatch_args(function() {}), NULL) +test_that("guesses dispatch_args from args after dots arguments", { + expect_equal(guess_dispatch_args(function() {}), character()) expect_equal(guess_dispatch_args(function(x) {}), "x") - expect_equal(guess_dispatch_args(function(x, y) {}), c("x", "y")) + expect_equal(guess_dispatch_args(function(x, y) {}), "x") + + expect_equal(guess_dispatch_args(function(...) {}), character()) expect_equal(guess_dispatch_args(function(x, y, ...) {}), c("x", "y")) - expect_equal(guess_dispatch_args(function(x, ..., y = 1) {}), c("x")) + expect_equal(guess_dispatch_args(function(x, ..., y = 1) {}), "x") }) test_that("check_dispatch_args() produces informative errors", { expect_snapshot(error = TRUE, { check_dispatch_args(1) check_dispatch_args(character()) + check_dispatch_args("...") + check_dispatch_args("x", function(x, y, ...) {}) + check_dispatch_args("y", function(x, ..., y) {}) }) }) diff --git a/tests/testthat/test-method.R b/tests/testthat/test-method.R index a4964370..624f0342 100644 --- a/tests/testthat/test-method.R +++ b/tests/testthat/test-method.R @@ -152,62 +152,36 @@ test_that("substitute() works for single dispatch method calls like S3", { }) test_that("method_compatible returns TRUE if the functions are compatible", { - foo <- new_generic("foo", dispatch_args = "x") - - expect_true( - method_compatible( - function(x, ...) x, - foo - ) - ) - + foo <- new_generic("foo", function(x, ...) method_call()) + expect_true(method_compatible(function(x, ...) x, foo)) # extra arguments are ignored - expect_true( - method_compatible( - function(x, y, ...) x, - foo - ) - ) + expect_true(method_compatible(function(x, ..., y) x, foo)) - foo <- new_generic("foo", function(x = NULL) method_call()) - expect_true( - method_compatible( - function(x = NULL) x, - foo - ) - ) + foo <- new_generic("foo", function(x) method_call()) + expect_true(method_compatible(function(x) x, foo)) bar <- new_generic("bar", dispatch_args = c("x", "y")) - expect_true( - method_compatible( - function(x, y, ...) x, - bar - ) - ) - - bar <- new_generic("bar", function(x=NULL, y=1, ...) method_call()) - expect_true( - method_compatible( - function(x = NULL, y = 1, ...) x, - bar - ) - ) + expect_true(method_compatible(function(x, y, ...) x, bar)) }) -test_that("method_compatible throws errors if the functions are not compatible", { - foo <- new_generic("foo", dispatch_args = "x") - # Different argument names - expect_snapshot_error(method_compatible(function(y) {}, foo)) - # Different default values - expect_snapshot_error(method_compatible(function(x = "foo") {}, foo)) +test_that("method_compatible errors if the functions are not compatible", { + expect_snapshot(error = TRUE, { + foo <- new_generic("foo", dispatch_args = "x") + method_compatible(function(y) {}, foo) + method_compatible(function(x = "foo") {}, foo) + method_compatible(function(x, y, ...) {}, foo) + }) +}) - bar <- new_generic("bar", dispatch_args = c("x", "y")) - # Arguments in wrong order - expect_snapshot_error(method_compatible(function(y, x, ...) {}, bar)) - # Different default values - expect_snapshot_error(method_compatible(function(x, y = NULL) {}, bar)) +test_that("method_compatible warn if default arguments don't match", { + expect_snapshot({ + foo <- new_generic("foo", function(x, ..., z = 2, y = 1) method_call()) + method_compatible(function(x, ..., y = 1) {}, foo) + method_compatible(function(x, ..., y = 1, z = 1) {}, foo) + }) }) + test_that("R7_method printing", { foo <- new_generic(name="foo", dispatch_args = c("x", "y")) method(foo, list(text, "integer")) <- function(x, y, ...) paste0("bar:", x, y) From 815a7151c03c165ab656387087a6e02933f86689 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 18 Jan 2022 15:20:22 -0600 Subject: [PATCH 13/15] Add additional checks and test --- R/generic.R | 16 ++++++++++++++++ man/new_generic.Rd | 12 ++++++++++++ tests/testthat/_snaps/generic.md | 12 ++++++++++++ tests/testthat/test-generic.R | 3 +++ 4 files changed, 43 insertions(+) diff --git a/R/generic.R b/R/generic.R index 4bb724f4..0976f3b4 100644 --- a/R/generic.R +++ b/R/generic.R @@ -5,6 +5,16 @@ #' of one or more arguments (the `signature`). Create a new generic with #' `new_generic()` then use [method<-] to add methods to it. #' +#' @section Dispatch arguments: +#' The arguments that are used to pick the method are called the **dispatch +#' arguments**. In most cases, this will be one argument, in which case the +#' generic is said to use **single dispatch**. If it consists of more than +#' one argument, it's said to use **multiple dispatch**. +#' +#' There are two restrictions on the dispatch arguments: they must be the first +#' arguments to the generic and if the generic uses `...`, it must occur +#' immediately after the dispatch arguments. +#' #' @param name The name of the generic. This should be the same as the object #' that you assign it to. #' @param dispatch_args A character vector providing the names of arguments to @@ -92,6 +102,12 @@ check_dispatch_args <- function(dispatch_args, fun = NULL) { if (length(dispatch_args) == 0) { stop("`dispatch_args` must have at least one component", call. = FALSE) } + if (anyDuplicated(dispatch_args)) { + stop("`dispatch_args` must be unique", call. = FALSE) + } + if (any(is.na(dispatch_args) | dispatch_args == "")) { + stop("`dispatch_args` must not be missing or the empty string") + } if ("..." %in% dispatch_args) { stop("Can't dispatch on `...`", call. = FALSE) } diff --git a/man/new_generic.Rd b/man/new_generic.Rd index fd2aef92..3a75f32c 100644 --- a/man/new_generic.Rd +++ b/man/new_generic.Rd @@ -29,6 +29,18 @@ A generic function uses different implementations depending on the class of one or more arguments (the \code{signature}). Create a new generic with \code{new_generic()} then use \link{method<-} to add methods to it. } +\section{Dispatch arguments}{ + +The arguments that are used to pick the method are called the \strong{dispatch +arguments}. In most cases, this will be one argument, in which case the +generic is said to use \strong{single dispatch}. If it consists of more than +one argument, it's said to use \strong{multiple dispatch}. + +There are two restrictions on the dispatch arguments: they must be the first +arguments to the generic and if the generic uses \code{...}, it must occur +immediately after the dispatch arguments. +} + \examples{ # A simple generic with methods for some base types and S3 classes type_of <- new_generic("type_of", dispatch_args = "x") diff --git a/tests/testthat/_snaps/generic.md b/tests/testthat/_snaps/generic.md index 88f479b8..e21c1831 100644 --- a/tests/testthat/_snaps/generic.md +++ b/tests/testthat/_snaps/generic.md @@ -12,6 +12,18 @@ check_dispatch_args(character()) Error `dispatch_args` must have at least one component + Code + check_dispatch_args("") + Error + `dispatch_args` must not be missing or the empty string + Code + check_dispatch_args(NA_character_) + Error + `dispatch_args` must not be missing or the empty string + Code + check_dispatch_args(c("x", "x")) + Error + `dispatch_args` must be unique Code check_dispatch_args("...") Error diff --git a/tests/testthat/test-generic.R b/tests/testthat/test-generic.R index b864c550..9af8400f 100644 --- a/tests/testthat/test-generic.R +++ b/tests/testthat/test-generic.R @@ -29,6 +29,9 @@ test_that("check_dispatch_args() produces informative errors", { expect_snapshot(error = TRUE, { check_dispatch_args(1) check_dispatch_args(character()) + check_dispatch_args("") + check_dispatch_args(NA_character_) + check_dispatch_args(c("x", "x")) check_dispatch_args("...") check_dispatch_args("x", function(x, y, ...) {}) check_dispatch_args("y", function(x, ..., y) {}) From bb8b89b8ff51b63c69f1c04add9daf3a63b15ffc Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 18 Jan 2022 15:20:27 -0600 Subject: [PATCH 14/15] Improve comments --- src/dispatch.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/dispatch.c b/src/dispatch.c index dbbd1fbd..9a539407 100644 --- a/src/dispatch.c +++ b/src/dispatch.c @@ -146,12 +146,11 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) { // And update the value of the promise to avoid evaluating it // again in the method body SET_PRVALUE(arg, val); - // Then add to arguments to method call + + // Then add to arguments of method call SETCDR(mcall_tail, Rf_cons(arg, R_NilValue)); - // We need to call `R7::object_class()`, as not every object has a class - // attribute, some are created dynamically. - // Now that we have the classes for the argument we can add them to the signature classes + // Determine class string to use for method look up SET_VECTOR_ELT(dispatch_classes, i, object_class_(val, envir)); } else { SETCDR(mcall_tail, Rf_cons(name, R_NilValue)); From dcc7eb3c4b85860252e89e51ff18da6ae66fdd0a Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 26 Jan 2022 12:53:56 -0600 Subject: [PATCH 15/15] Add news bullet --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index b07d63d6..038cebf1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,8 @@ ## Jan 2020 +* Different evaluation mechanism for method dispatch, and greater restrictions + on dispatch args (#141) * `x@.data` -> `r7_data()`; probably to be replaced by casting. * In generic, `signature` -> `dispatch_args`. * `new_class()` has properties as 3rd argument (instead of constructor).