S7/0000755000176200001440000000000014713133572010551 5ustar liggesusersS7/tests/0000755000176200001440000000000014712722330011706 5ustar liggesusersS7/tests/testthat/0000755000176200001440000000000014713133572013553 5ustar liggesusersS7/tests/testthat/test-generic-spec.R0000644000176200001440000000115314512327350017213 0ustar liggesuserstest_that("can standardise generics", { foo_S7 <- new_generic("foo", "x") methods::setGeneric("foo_S4", function(x) {}) expect_equal(as_generic(foo_S7), foo_S7) expect_equal(as_generic(foo_S4), foo_S4) expect_equal(as_generic(sum), S3_generic(sum, "sum")) expect_equal(as_generic(mean), S3_generic(mean, "mean")) expect_snapshot(as_generic(function() {}), error = TRUE) expect_snapshot(as_generic(1), error = TRUE) }) test_that("base ops use S7 shim", { expect_equal(as_generic(`+`), base_ops[["+"]]) if(getRversion() >= "4.3.0") expect_equal(as_generic(`%*%`), base_matrix_ops[["%*%"]]) }) S7/tests/testthat/test-S3.R0000644000176200001440000000400414712423107015131 0ustar liggesuserstest_that("new_S3_class has a print method", { expect_snapshot(new_S3_class(c("ordered", "factor"))) }) test_that("can construct objects that extend S3 classes", { ordered2 <- new_class("ordered2", parent = class_factor, package = NULL) x <- ordered2(c(1L, 2L, 1L), letters[1:3]) expect_equal(class(x), c("ordered2", "factor", "S7_object")) expect_equal(prop_names(x), character()) expect_error(x@levels, "Can't find property") }) test_that("subclasses inherit validator", { foo <- new_S3_class("foo", function(.data) structure(.data, class = "foo"), function(x) if (!is.double(x)) "Underlying data must be a double" ) foo2 <- new_class("foo2", foo, package = NULL) expect_snapshot(error = TRUE, foo2("a")) }) test_that("new_S3_class() checks its inputs", { expect_snapshot(new_S3_class(1), error = TRUE) expect_snapshot(error = TRUE, { new_S3_class("foo", function(x) {}) new_S3_class("foo", function(.data, ...) {}) }) }) test_that("default new_S3_class constructor errors", { # constructor errors if needed expect_snapshot(class_construct(new_S3_class("foo"), 1), error = TRUE) }) test_that("can construct data frame subclass", { dataframe2 <- new_class("dataframe2", class_data.frame) df <- dataframe2(list(x = 1:3)) expect_s3_class(df, "data.frame") }) # Basic tests of validators ----------------------------------------------- test_that("catches invalid factors", { expect_snapshot({ validate_factor(structure("x")) }) }) test_that("catches invalid dates", { expect_snapshot({ validate_date("x") }) }) test_that("catches invalid POSIXct", { expect_snapshot({ validate_POSIXct(structure("x", tz = "UTC")) validate_POSIXct(structure(1, tz = 1)) }) }) test_that("catches invalid data.frame", { expect_snapshot({ validate_data.frame(1) validate_data.frame(structure(list(x = 1, y = 1:2), row.names = 1L)) validate_data.frame(structure(list(x = 1, y = 1), row.names = 1:2)) validate_data.frame(structure(list(1), row.names = 1L)) }) }) S7/tests/testthat/t1/0000755000176200001440000000000014703771245014103 5ustar liggesusersS7/tests/testthat/t1/R/0000755000176200001440000000000014703771245014304 5ustar liggesusersS7/tests/testthat/t1/R/t1.R0000644000176200001440000000023214703771245014750 0ustar liggesusers#' @export another_s7_generic <- S7::new_generic("another_s7_generic", "x") #' @export another_s3_generic <- function(x) UseMethod("another_s3_generic") S7/tests/testthat/t1/NAMESPACE0000644000176200001440000000014414703771245015321 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(another_s3_generic) export(another_s7_generic) S7/tests/testthat/t1/DESCRIPTION0000644000176200001440000000103614703771245015611 0ustar liggesusersPackage: t1 Title: What the Package Does (One Line, Title Case) Version: 0.0.0.9000 Authors@R: c(person(given = "Jim", family = "Hester", role = c("aut", "cre"), email = "james.f.hester@gmail.com", comment = c(ORCID = "0000-0002-2739-7082")), person(given = "RStudio", role = c("cph", "fnd"))) Description: What the package does (one paragraph). Imports: S7 License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 S7/tests/testthat/test-super.R0000644000176200001440000000236514712423107016012 0ustar liggesusers describe("super()", { it("overrides dispatch, matching inherited behaviour", { foo1 <- new_class("foo1") foo2 <- new_class("foo2", foo1) foo3 <- new_class("foo3", foo2) bar <- new_generic("bar", "x") method(bar, foo1) <- function(x) 1 method(bar, foo3) <- function(x) 3 expect_equal(bar(super(foo3(), to = foo2)), 1) expect_equal(bar(super(foo3(), to = foo1)), 1) }) it("only affects one dispatch", { foo1 <- new_class("foo1") foo2 <- new_class("foo2", foo1) bar1 <- new_generic("bar1", "x") method(bar1, foo1) <- function(x) 1 method(bar1, foo2) <- function(x) 2 bar2 <- new_generic("bar2", "x") method(bar2, foo1) <- function(x) c(1, bar1(x)) method(bar2, foo2) <- function(x) c(2, bar1(x)) expect_equal(bar2(super(foo2(), to = foo1)), c(1, 2)) expect_equal(bar2(convert(foo2(), to = foo1)), c(1, 1)) }) it("checks to", { expect_snapshot(error = TRUE, { foo <- new_class("foo", package = NULL) super(foo(), class_character) }) }) it("displays nicely", { foo1 <- new_class("foo1", package = NULL) foo2 <- new_class("foo2", foo1, package = NULL) expect_snapshot({ f1 <- super(foo2(), foo1) f1 str(list(f1)) }) }) }) S7/tests/testthat/test-S4.R0000644000176200001440000000743214703771245015153 0ustar liggesuserstest_that("can work with classGenerators", { on.exit(S4_remove_classes("Foo")) Foo <- setClass("Foo") expect_equal(S4_to_S7_class(Foo), getClass("Foo")) }) test_that("converts S4 base classes to S7 base classes", { expect_equal(S4_to_S7_class(getClass("NULL")), NULL) expect_equal(S4_to_S7_class(getClass("character")), class_character) }) test_that("converts S4 unions to S7 unions", { on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3", "Union1", "Union2"))) setClass("Foo1", slots = "x") setClass("Foo2", slots = "x") setClassUnion("Union1", c("Foo1", "Foo2")) expect_equal( S4_to_S7_class(getClass("Union1")), new_union(getClass("Foo1"), getClass("Foo2")) ) setClass("Foo3", slots = "x") setClassUnion("Union2", c("Union1", "Foo3")) expect_equal( S4_to_S7_class(getClass("Union2")), new_union(getClass("Foo1"), getClass("Foo2"), getClass("Foo3")) ) }) test_that("converts S4 representation of S3 classes to S7 representation", { expect_equal(S4_to_S7_class(getClass("Date")), class_Date, ignore_function_env = TRUE) }) test_that("errors on non-S4 classes", { expect_snapshot(S4_to_S7_class(1), error = TRUE) }) describe("S4_class_dispatch", { it("returns name of base class", { on.exit(S4_remove_classes("Foo1")) setClass("Foo1", slots = list("x" = "numeric")) expect_equal(S4_class_dispatch("Foo1"), "S4/S7::Foo1") }) it("respects single inheritance hierarchy", { on.exit(S4_remove_classes(c("Foo1", "Foo2","Foo3"))) setClass("Foo1", slots = list("x" = "numeric")) setClass("Foo2", contains = "Foo1") setClass("Foo3", contains = "Foo2") expect_equal(S4_class_dispatch("Foo3"), c("S4/S7::Foo3", "S4/S7::Foo2", "S4/S7::Foo1")) }) it("performs breadth first search for multiple dispatch", { on.exit(S4_remove_classes(c("Foo1a", "Foo1b","Foo2a", "Foo2b", "Foo3"))) setClass("Foo1a", slots = list("x" = "numeric")) setClass("Foo1b", contains = "Foo1a") setClass("Foo2a", slots = list("x" = "numeric")) setClass("Foo2b", contains = "Foo2a") setClass("Foo3", contains = c("Foo1b", "Foo2b")) expect_equal( S4_class_dispatch("Foo3"), c("S4/S7::Foo3", "S4/S7::Foo1b", "S4/S7::Foo2b", "S4/S7::Foo1a", "S4/S7::Foo2a") ) }) it("handles extensions of base classes", { on.exit(S4_remove_classes("Foo1")) setClass("Foo1", contains = "character") expect_equal(S4_class_dispatch("Foo1"), c("S4/S7::Foo1", "character")) }) it("handles extensions of S3 classes", { on.exit(S4_remove_classes(c("Soo1", "Foo2", "Foo3"))) setOldClass(c("Soo1", "Soo")) setClass("Foo2", contains = "Soo1") setClass("Foo3", contains = "Foo2") expect_equal(S4_class_dispatch("Foo3"), c("S4/S7::Foo3", "S4/S7::Foo2", "Soo1", "Soo")) }) it("ignores unions", { on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3"))) setClass("Foo1", slots = list("x" = "numeric")) setClass("Foo2", slots = list("x" = "numeric")) setClassUnion("Foo3", c("Foo1", "Foo2")) expect_equal(S4_class_dispatch("Foo1"), "S4/S7::Foo1") expect_equal(S4_class_dispatch("Foo2"), "S4/S7::Foo2") }) it("includes virtual classes", { on.exit(S4_remove_classes(c("Foo1", "Foo2"))) setClass("Foo1") setClass("Foo2", contains = "Foo1") expect_equal(S4_class_dispatch("Foo1"), "S4/S7::Foo1") expect_equal(S4_class_dispatch("Foo2"), c("S4/S7::Foo2", "S4/S7::Foo1")) }) it("captures explicit package name", { on.exit(S4_remove_classes("Foo1")) setClass("Foo1", package = "pkg") expect_equal(S4_class_dispatch("Foo1"), "S4/pkg::Foo1") }) it("captures implicit package name", { on.exit(S4_remove_classes("Foo1", env)) env <- new.env() env$.packageName <- "mypkg" setClass("Foo1", where = env) expect_equal(S4_class_dispatch("Foo1"), "S4/mypkg::Foo1") }) }) S7/tests/testthat/test-property.R0000644000176200001440000003245714712423107016545 0ustar liggesusersdescribe("property retrieval", { it("retrieves the properties that exist & errors otherwise", { foo <- new_class("foo", properties = list(xyz = class_double), package = NULL) obj <- foo(1) expect_equal(prop(obj, "xyz"), 1) expect_equal(obj@xyz, 1) expect_snapshot_error(prop(obj, "x")) expect_snapshot_error(obj@x) }) it("evalutes dynamic properties", { foo <- new_class("foo", properties = list( x = new_property(getter = function(self) 1) )) obj <- foo() expect_equal(prop(obj, "x"), 1) expect_equal(obj@x, 1) }) it("falls back to `base::@` for non-S7 objects", { expect_error("foo"@blah, 'object of.+class.+"character"') expect_error(NULL@blah, 'object of.+class.+"NULL"') }) }) describe("prop setting", { it("can set a property", { foo <- new_class("foo", properties = list(xyz = class_double)) obj <- foo(1) prop(obj, "xyz") <- 2 expect_equal(obj@xyz, 2) obj@xyz <- 3 expect_equal(obj@xyz, 3) }) it("can set dynamic properties", { foo <- new_class("foo", properties = list( x = new_property(setter = function(self, value) { self@x <- value * 2 self }) )) obj <- foo() obj@x <- 1 expect_equal(obj@x, 2) }) it("can't set read-only properties", { foo <- new_class("foo", package = NULL, properties = list( x = new_property(getter = function(self) 1 ))) obj <- foo() expect_snapshot(obj@x <- 1, error = TRUE) }) it("errors if the property doesn't exist or is wrong class", { foo <- new_class("foo", properties = list(x = class_double), package = NULL) expect_snapshot(error = TRUE, { obj <- foo(123) obj@foo <- 10 obj@x <- "x" }) }) it("validates all attributes if custom setter", { foo <- new_class("foo", package = NULL, properties = list( x = new_property( class_double, setter = function(self, value) { self@x <- 123 self@y <- value self } ), y = new_property(class_double) )) expect_snapshot(error = TRUE, { obj <- foo(y = 123, x = 123) obj@x <- "x" }) }) it("validates once after custom setter", { times_validated <- 0L; `add<-` <- `+` custom_setter <- function(self, value) { self@x <- as.double(value) self } foo2 <- new_class( "foo2", properties = list(x = new_property(class_double, setter = custom_setter)), validator = function(self) { add(times_validated) <<- 1L character() } ) obj <- foo2("123") expect_equal(times_validated, 1) obj@x <- "456" expect_equal(times_validated, 2) }) it("validates once with recursive property setters", { times_validated <- 0L; `add<-` <- `+` foo <- new_class( "foo", properties = list( x = new_property(setter = function(self, value) { self@x <- value self@y <- paste0(value, "_set_by_x_setter") self }), y = new_property(setter = function(self, value) { self@y <- value self@z <- paste0(value, "_set_by_y_setter") self }), z = new_property(class_character) ), validator = function(self) { add(times_validated) <<- 1L; NULL } ) out <- foo() expect_equal(times_validated, 1L) out@x <- "VAL" expect_equal(times_validated, 2L) expect_equal(out@z, "VAL_set_by_x_setter_set_by_y_setter") }) it("does not run the check or validation functions if check = FALSE", { foo <- new_class("foo", properties = list(x = class_double)) obj <- foo(123) prop(obj, "x", check = FALSE) <- "foo" expect_equal(obj@x, "foo") }) it("falls back to `base::@` for non-S7 objects", { x <- "foo" expect_error(x@blah <- "bar", "is not a slot in class") }) }) describe("props<-", { it("validates after setting all properties", { foo <- new_class("foo", properties = list(x = class_double, y = class_double), validator = function(self) if (self@x > self@y) "bad" ) obj <- foo(1, 2) props(obj) <- list(x = 5, y = 10) expect_equal(obj@x, 5) expect_equal(obj@y, 10) }) it("has ordinary syntax in set_props()", { foo <- new_class("foo", properties = list(x = class_double)) obj1 <- foo(1) obj2 <- set_props(obj1, x = 2) expect_equal(obj1@x, 1) expect_equal(obj2@x, 2) }) }) describe("property access", { it("access en masse", { foo <- new_class("foo", properties = list(x = class_numeric, y = class_numeric)) x <- foo(x = 1, y = 2) expect_equal(prop_names(x), c("x", "y")) expect_equal(props(x), list(x = 1, y = 2)) expect_true(prop_exists(x, "x")) expect_true(prop_exists(x, "y")) expect_false(prop_exists(x, "z")) }) it("can access dynamic properties", { foo <- new_class("foo", properties = list( x = new_property(getter = function(self) 10), y = new_property() )) x <- foo(y = 2) expect_equal(props(x), list(x = 10, y = 2)) }) it("can with property-less object", { x <- new_class("x")() expect_equal(prop_names(x), character()) expect_equal(props(x), named_list()) expect_equal(prop_exists(x, "y"), FALSE) }) it("ignore attributes that are not properties", { x <- new_class("x")() attr(x, "extra") <- 1 expect_equal(prop_names(x), character()) expect_equal(props(x), named_list()) expect_false(prop_exists(x, "extra")) }) }) test_that("properties can be NULL", { foo <- new_class("foo", properties = list(x = class_any)) x <- foo(x = NULL) expect_equal(x@x, NULL) x@x <- 1 expect_equal(x@x, 1) x@x <- NULL expect_equal(x@x, NULL) expect_equal(prop_names(x), "x") expect_equal(props(x), list(x = NULL)) }) describe("new_property()", { it("validates getter and settor", { expect_snapshot(error = TRUE, { new_property(getter = function(x) {}) new_property(setter = function(x, y, z) {}) }) }) it("validates default", { expect_snapshot(error = TRUE, { new_property(class_integer, default = "x") }) }) it("displays nicely", { x <- new_property(class_integer, name = "foo") expect_snapshot({ print(x) str(list(x)) }) }) }) test_that("properties can be base, S3, S4, S7, or S7 union", { class_S7 <- new_class("class_S7", package = NULL) class_S4 <- methods::setClass("class_S4", slots = c(x = "numeric")) my_class <- new_class("my_class", package = NULL, properties = list( anything = class_any, null = NULL, base = class_integer, S3 = class_factor, S4 = class_S4, S7 = class_S7, S7_union = new_union(class_integer, class_logical) ) ) expect_snapshot(my_class) my_obj <- my_class( anything = TRUE, null = NULL, base = 1L, S3 = factor(), S4 = class_S4(x = 1), S7 = class_S7(), S7_union = 1L ) # First check that we can set with out error expect_error(my_obj@base <- 2L, NA) expect_error(my_obj@S3 <- factor("x"), NA) expect_error(my_obj@S4 <- class_S4(x = 2), NA) expect_error(my_obj@S7 <- class_S7(), NA) expect_error(my_obj@S7_union <- 2L, NA) expect_error(my_obj@S7_union <- TRUE, NA) # Then capture the error messages for human inspection expect_snapshot(error = TRUE, { my_obj@null <- "x" my_obj@base <- "x" my_obj@S3 <- "x" my_obj@S4 <- "x" my_obj@S7 <- "x" my_obj@S7_union <- "x" }) }) test_that("as_properties normalises properties", { expect_equal(as_properties(NULL), list()) expect_equal( as_properties(list(x = class_numeric)), list(x = new_property(class_numeric, name = "x") )) expect_equal( as_properties(list(x = new_property(class = class_numeric))), list(x = new_property(class_numeric, name = "x") )) expect_equal( as_properties(list(new_property(name = "y"))), list(y = new_property(name = "y") )) # list name wins expect_equal( as_properties(list(x = new_property(name = "y"))), list(x = new_property(name = "x") )) }) test_that("as_properties() gives useful error messages", { expect_snapshot(error = TRUE, { as_properties(1) as_properties(list(1)) as_properties(list(new_property(class_character))) as_properties(list(x = 1)) as_properties(list(x = class_character, x = class_character)) }) }) test_that("can validate with custom validator", { validate_scalar <- function(value) { if (length(value) != 1) { "must be length 1" } } prop <- new_property(class_integer, validator = validate_scalar) foo <- new_class("foo", package = NULL, properties = list(x = prop)) expect_snapshot(error = TRUE, { f <- foo(x = 1L) f@x <- 1:2 foo(x = 1:2) }) }) test_that("prop<- won't infinitly recurse on a custom setter", { chattily_sync_ab <- function(self, value) { cat("Starting syncup with value:", value, "\n") a_value <- paste0("a_", value) b_value <- paste0("b_", value) cat(sprintf('setting @a <- "%s"\n', a_value)) self@a <- a_value cat(sprintf('setting @b <- "%s"\n', b_value)) self@b <- b_value self } foo <- new_class("foo", properties = list( a = new_property(setter = chattily_sync_ab), b = new_property(setter = chattily_sync_ab) )) expect_snapshot({ obj <- foo() obj@a <- "val" }) }) test_that("custom setters can invoke setters on non-self objects", { Transmitter <- new_class("Transmitter", properties = list( message = new_property(setter = function(self, value) { cat("[tx] sending: ", value, "\n") receiver@message <<- value cat("[tx] saving last sent message.\n") self@message <- value cat("[tx] finished transmitting.\n") self }) )) Receiver <- new_class("Receiver", properties = list( message = new_property(setter = function(self, value) { cat("[rx] receiving: ", value, "\n") self@message <- value cat("[rx] finished receiving.\n") self }) )) expect_snapshot({ receiver <- Receiver() transmitter <- Transmitter() transmitter@message <- "hello" expect_equal(receiver@message, "hello") transmitter@message <- "goodbye" expect_equal(receiver@message, "goodbye") }) }) test_that("custom getters don't infinitely recurse", { # https://github.com/RConsortium/S7/issues/403 someclass <- new_class("someclass", properties = list( someprop = new_property( class_character, getter = function(self) self@someprop, setter = function(self, value) { self@someprop <- toupper(value) self } ) )) expect_equal(someclass("foo")@someprop, "FOO") x <- someclass() expect_equal(x@someprop, character()) x@someprop <- "foo" expect_equal(x@someprop, "FOO") }) test_that("custom setters can call custom getters", { # https://github.com/RConsortium/S7/issues/403 someclass <- new_class("someclass", properties = list( someprop = new_property( class_character, getter = function(self) self@someprop, setter = function(self, value) { self@someprop <- paste0(self@someprop, toupper(value)) self } ) )) x <- someclass("foo") expect_equal(x@someprop, "FOO") x <- someclass() expect_equal(x@someprop, character()) x@someprop <- "foo" expect_equal(x@someprop, "FOO") x@someprop <- "foo" expect_equal(x@someprop, "FOOFOO") }) test_that("custom getters don't evaulate call objects", { QuotedCall := new_class(class_call, properties = list( name = new_property(getter = function(self) { stopifnot(is.call(self)) as.character(self[[1]]) }), args = new_property(getter = function(self) { stopifnot(is.call(self)) as.list(self)[-1] }) ), constructor = function(x) { new_object(substitute(x)) }) cl <- QuotedCall(stop("boom")) expect_equal(cl@name, "stop") expect_equal(cl@args, list("boom")) }) test_that("custom setters don't evaulate call objects", { Call := new_class(class_call, properties = list( name = new_property( getter = function(self) { stopifnot(is.call(self)) as.character(self[[1]]) }, setter = function(self, value) { stopifnot(is.call(self), is.name(value)) self[[1]] <- value self } ), args = new_property( getter = function(self) { stopifnot(is.call(self)) as.list(self)[-1] }, setter = function(self, value) { stopifnot(is.call(self), is.list(value) || is.pairlist(value)) # self[seq(2, length.out = length(value))] <- value # names(self) <- c("", names(value)) # self out <- as.call(c(self[[1]], value)) attributes(out) <- attributes(self) out }) ), constructor = function(name, ...) { new_object(as.call(c(as.name(name), ...))) }) cl <- Call("stop", "boom") expect_identical(cl@name, "stop") expect_identical(cl@args, list("boom")) abort <- stop cl@name <- quote(abort) expect_identical(cl@name, "abort") expect_identical(cl[[1]], quote(abort)) cl@args <- pairlist("boom2") expect_identical(cl[[2]], "boom2") expect_identical(cl@args, list("boom2")) expect_identical(drop_attributes(cl), quote(abort("boom2"))) cl@args <- alist(msg = "boom3", foo = bar, baz) expect_identical(cl@args, alist(msg = "boom3", foo = bar, baz)) expect_identical(drop_attributes(cl), quote(abort(msg = "boom3", foo = bar, baz))) }) S7/tests/testthat/test-union.R0000644000176200001440000000453214712423107016002 0ustar liggesuserstest_that("has useful print method", { expect_snapshot({ foo1 <- new_class("foo1", package = NULL) foo2 <- new_class("foo2", package = NULL) new_union(foo1, foo2) }) }) test_that("can construct from base types", { u1 <- new_union(class_character) expect_s3_class(u1, "S7_union") expect_equal(u1$classes, list(class_character)) u2 <- new_union(class_character, class_integer) expect_s3_class(u2, "S7_union") expect_equal(u2$classes, list(class_character, class_integer)) }) test_that("can construct from unions", { u1 <- new_union(class_character) u2 <- new_union(class_integer) u3 <- new_union(u1, u2) expect_s3_class(u3, "S7_union") expect_equal(u3$classes, list(class_character, class_integer)) expect_equal(new_union(u1, class_integer), u3) }) test_that("base unions display as expected", { expect_snapshot({ class_vector str(class_vector) }) }) test_that("can construct from S3 and S4 classes", { S4_union <- methods::setClass("S4_union") on.exit(S4_remove_classes("S4_union")) u <- new_union(class_factor, S4_union) expect_equal(u$classes, list(class_factor, getClass("S4_union"))) }) test_that("can construct with |", { foo <- new_class("foo") Foo1 <- setClass("Foo1", slots = list("x" = "numeric")) Foo2 <- setClass("Foo2", slots = list("x" = "numeric")) Foo3 <- setClassUnion("Foo3", c("Foo1", "Foo2")) on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3"))) expect_equal(class_integer | class_double, class_numeric) expect_equal(class_integer | class_numeric, class_numeric) expect_equal(class_integer | class_factor, new_union(class_integer, class_factor)) expect_equal(class_integer | foo, new_union(class_integer, foo)) expect_equal(class_integer | Foo1, new_union(class_integer, Foo1)) expect_equal(class_integer | getClass("Foo1"), new_union(class_integer, Foo1)) expect_equal(class_integer | Foo3, new_union(class_integer, Foo3)) expect_equal(class_integer | getClass("Foo3"), new_union(class_integer, Foo3)) expect_equal(class_integer | class_missing, new_union(class_integer, class_missing)) expect_equal(class_integer | class_any, new_union(class_integer, class_any)) }) test_that("can construct optional union with syntactic sugar", { expect_equal(class_integer | NULL, new_union(class_integer, NULL)) expect_equal(NULL | class_integer, new_union(NULL, class_integer)) }) S7/tests/testthat/test-method-introspect.R0000644000176200001440000000254614712423107020325 0ustar liggesusersdescribe("method introspection", { it("can dispatch by class or object", { foo <- new_generic("foo", "x") method(foo, class_character) <- function(x) "c" expect_equal( method(foo, class = class_character), method(foo, object = "x") ) }) it("errors on invalid inputs", { expect_snapshot(error = TRUE, { method(print, 1) foo <- new_generic("foo", "x") method(foo) method(foo, 1) method(foo, new_union(class_integer, class_double)) foo2 <- new_generic("foo2", c("x", "y")) method(foo2, object = list(class_character)) }) }) it("errors if no method found", { foo <- new_generic("foo", "x") foo2 <- new_generic("foo", c("x", "y")) expect_snapshot(error = TRUE, { method(foo, class = class_integer) method(foo, object = 1L) method(foo2, class = list(class_integer, class_double)) method(foo2, object = list(1L, 2)) }) }) }) describe("method explanation", { it("shows all possible methods along with matches", { foo1 <- new_class("foo1", package = NULL) foo2 <- new_class("foo2", foo1, package = NULL) add <- new_generic("add", c("x", "y")) method(add, list(foo2, foo1)) <- function(x, y) c(2, 1) method(add, list(foo1, foo1)) <- function(x, y) c(1, 1) expect_snapshot_output(method_explain(add, list(foo2, foo2))) }) }) S7/tests/testthat/test-constructor.R0000644000176200001440000001446414712423107017244 0ustar liggesuserstest_that("generates correct arguments from parent + properties", { # No arguments args <- constructor_args(S7_object) expect_equal(args$self, pairlist()) expect_equal(args$parent, pairlist()) # Includes properties args <- constructor_args(S7_object, as_properties(list(x = class_numeric))) expect_equal(args$self, pairlist(x = integer())) expect_equal(args$parent, pairlist()) # test constructor arg defaults args <- constructor_args(S7_object, as_properties(list( a = class_any, b = class_missing, c = NULL | class_character, d = class_missing | class_numeric ))) expect_identical(args$self, as.pairlist(alist(a = NULL, b =, c = NULL, d =))) expect_identical(args$parent, pairlist()) # unless they're dynamic args <- constructor_args(S7_object, as_properties(list(x = new_property(getter = function(self) 10))) ) expect_equal(args$self, pairlist()) expect_equal(args$parent, pairlist()) # Includes parent properties foo <- new_class("foo", properties = list(x = class_numeric)) args <- constructor_args(foo, as_properties(list(y = class_numeric))) expect_equal(args$self, pairlist(y = integer())) expect_equal(args$parent, pairlist(x = integer())) # But only those in the constructor foo <- new_class("foo", properties = list(x = class_numeric), constructor = function() new_object(x = 1) ) args <- constructor_args(foo, as_properties(list(y = class_numeric))) expect_equal(args$self, pairlist(y = integer())) expect_equal(args$parent, pairlist()) }) test_that("generates meaningful constructors", { expect_snapshot({ new_constructor(S7_object, list()) new_constructor(S7_object, as_properties(list(x = class_numeric, y = class_numeric))) foo <- new_class("foo", parent = class_character) new_constructor(foo, list()) foo2 <- new_class("foo2", parent = foo) new_constructor(foo2, list()) }, transform = scrub_environment) }) test_that("can generate constructors for S3 classes", { expect_snapshot({ new_constructor(class_factor, list()) new_constructor(class_factor, as_properties(list(x = class_numeric, y = class_numeric))) }, transform = scrub_environment) }) test_that("can generate constructor for inherited abstract classes", { expect_snapshot({ foo1 <- new_class("foo1", abstract = TRUE, properties = list(x = class_double)) new_constructor(foo1, list()) new_constructor(foo1, as_properties(list(y = class_double))) }, transform = scrub_environment) child <- new_class("child", foo1, properties = list(y = class_double)) expect_no_error(child(y = 0.5)) # even if it has a read-only property prop_readonly <- new_property(getter = function(self) "test") child <- new_class("child", foo1, properties = list(x = prop_readonly)) expect_no_error(child()) }) test_that("can use `...` in parent constructor", { foo <- new_class( "foo", properties = list(x = class_list), constructor = function(...) new_object(S7_object(), x = list(...)) ) expect_snapshot( new_constructor(foo, list(y = class_double)), transform = scrub_environment ) # And check that arguments matched correctly bar <- new_class("bar", foo, properties = list(y = class_double)) expect_equal(bar()@x, list()) expect_equal(bar(2)@x, list(2)) expect_equal(bar(y = 2)@x, list()) }) test_that("can create constructors with missing or lazy defaults", { Person <- new_class( name = "Person", properties = list( # non-dynamic, default error call (required constructor arg) first_name = new_property(class_character, default = quote(stop( 'argument "first_name" is missing, with no default'))), # non-dynamic, static default (optional constructor arg) middle_name = new_property(class_character, default = ""), # non-dynamic, nullable character last_name = new_property(NULL | class_character), # non-dynamic, but defaults to the value of another property nick_name = new_property(class_character, default = quote(first_name)), # non-dynamic, optional constructor argument, read-only after construction. birthdate = new_property( class = class_Date, default = quote(Sys.Date()), setter = function(self, value) { if (!is.null(self@birthdate)) stop("Can't set read-only property Person@birthdate") self@birthdate <- value self } ), # dynamic property, not a constructor argument age = new_property(class = class_any, getter = function(self) { Sys.Date() - self@birthdate }) ) ) expect_equal(formals(Person), as.pairlist(alist( first_name = stop('argument "first_name" is missing, with no default'), middle_name = "", last_name = NULL, nick_name = first_name, birthdate = Sys.Date() ))) # no age expect_error(Person(), 'argument "first_name" is missing, with no default') expect_null(Person("Alice")@last_name) p <- Person("Alice", ,"Smith") expect_equal(p@nick_name, "Alice") expect_equal(p@middle_name, "") expect_equal(p@birthdate, Sys.Date()) expect_equal(p@age, Sys.Date() - Sys.Date()) p <- Person("Bob", nick_name = "Bobby", "Allen" , "Smith", as.Date('1970-01-01')) expect_equal(p@nick_name, "Bobby") expect_equal(p@birthdate, as.Date('1970-01-01')) expect_equal(p@age, Sys.Date() - as.Date('1970-01-01')) expect_equal(p@middle_name, "Allen") expect_error(p@birthdate <- as.Date('1970-01-01'), "Can\'t set read-only property Person@birthdate") }) test_that("Dynamic settable properties are included in constructor", { Foo <- new_class( name = "Foo", package = NULL, properties = list( dynamic_settable = new_property( class_numeric, getter = function(self) self@dynamic_settable, setter = function(self, value) { self@dynamic_settable <- value self } ), dynamic_read_only = new_property( class_numeric, getter = function(self) 99, ) ) ) expect_equal(formals(Foo), pairlist(dynamic_settable = numeric())) expect_equal(Foo()@dynamic_settable, numeric()) expect_equal(Foo(3)@dynamic_settable, 3) foo <- Foo() expect_error(foo@dynamic_read_only <- 1, "Can't set read-only property @dynamic_read_only") foo@dynamic_settable <- 1 expect_equal(foo@dynamic_settable, 1) }) S7/tests/testthat/t0/0000755000176200001440000000000014712423107014071 5ustar liggesusersS7/tests/testthat/t0/R/0000755000176200001440000000000014712423107014272 5ustar liggesusersS7/tests/testthat/t0/R/t0.R0000644000176200001440000000030014712423107014731 0ustar liggesusers#' @export an_s7_generic <- S7::new_generic("an_s7_generic", "x") #' @export an_s3_generic <- function(x) UseMethod("an_s3_generic") #' @export `An S7 Class` <- S7::new_class("An S7 Class") S7/tests/testthat/t0/NAMESPACE0000644000176200001440000000016014712423107015305 0ustar liggesusers# Generated by roxygen2: do not edit by hand export("An S7 Class") export(an_s3_generic) export(an_s7_generic) S7/tests/testthat/t0/DESCRIPTION0000644000176200001440000000103614703771245015610 0ustar liggesusersPackage: t0 Title: What the Package Does (One Line, Title Case) Version: 0.0.0.9000 Authors@R: c(person(given = "Jim", family = "Hester", role = c("aut", "cre"), email = "james.f.hester@gmail.com", comment = c(ORCID = "0000-0002-2739-7082")), person(given = "RStudio", role = c("cph", "fnd"))) Description: What the package does (one paragraph). Imports: S7 License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 S7/tests/testthat/test-class.R0000644000176200001440000001601214712423107015753 0ustar liggesusersdescribe("S7 classes", { it("possess expected properties", { foo <- new_class("foo", package = "S7", validator = function(self) NULL) expect_equal(prop_names(foo), setdiff(names(attributes(foo)), "class")) expect_type(foo@name, "character") expect_equal(foo@parent, S7_object) expect_type(foo@constructor, "closure") expect_type(foo@validator, "closure") expect_type(foo@properties, "list") }) it("print nicely", { foo1 <- new_class("foo1", properties = list(x = class_integer, y = class_integer), package = NULL) foo2 <- new_class("foo2", foo1, package = NULL) expect_snapshot({ foo2 str(foo2) # Omit details when nested str(list(foo2)) }) }) it("prints @package and @abstract details", { foo <- new_class("foo", package = "S7", abstract = TRUE) expect_snapshot(foo) }) it("checks inputs", { expect_snapshot(error = TRUE, { new_class(1) new_class("foo", 1) new_class("foo", package = 1) new_class("foo", constructor = 1) new_class("foo", constructor = function() {}) new_class("foo", validator = function() {}) }) }) it("can't inherit from S4 or class unions", { parentS4 <- methods::setClass("parentS4", slots = c(x = "numeric")) expect_snapshot(error = TRUE, { new_class("test", parent = parentS4) new_class("test", parent = new_union("character")) }) }) it("can't inherit from an environment", { expect_snapshot(error = TRUE, { new_class("test", parent = class_environment) }) }) }) describe("inheritance", { it("combines properties for parent classes", { foo1 <- new_class("foo1", properties = list(x = class_double)) foo2 <- new_class("foo2", foo1, properties = list(y = class_double)) expect_equal(names(foo2@properties), c("x", "y")) }) it("child properties override parent", { foo1 <- new_class("foo1", properties = list(x = class_numeric)) foo2 <- new_class("foo2", foo1, properties = list(x = class_double)) expect_equal(names(foo2@properties), "x") expect_equal(foo2@properties$x$class, class_double) }) }) describe("abstract classes", { it("can't be instantiated", { expect_snapshot(error = TRUE, { foo <- new_class("foo", abstract = TRUE) foo() }) }) it("can't inherit from concrete class", { expect_snapshot(error = TRUE, { foo1 <- new_class("foo1") new_class("foo2", parent = foo1, abstract = TRUE) }) }) it("can construct concrete subclasses", { foo1 <- new_class("foo1", abstract = TRUE, package = NULL) foo2 <- new_class("foo2", parent = foo1, package = NULL) expect_s3_class(foo2(), "foo2") }) it("can use inherited validator from abstract class", { foo1 <- new_class( "foo1", properties = list(x = class_double), abstract = TRUE, validator = function(self) { if (self@x == 2) "@x has bad value" }, package = NULL ) foo2 <- new_class("foo2", parent = foo1, package = NULL) expect_no_error(foo2(x = 1)) expect_snapshot(foo2(x = 2), error = TRUE) }) }) describe("new_object()", { it("gives useful error if called directly",{ expect_snapshot(new_object(), error = TRUE) }) it("validates object", { foo <- new_class("foo", properties = list(x = new_property(class_double)), validator = function(self) if (self@x < 0) "x must be positive", package = NULL ) expect_snapshot(error = TRUE, { foo("x") foo(-1) }) }) it("runs each parent validator exactly once", { A <- new_class("A", validator = function(self) cat("A ")) B <- new_class("B", parent = A, validator = function(self) cat("B ")) C <- new_class("C", parent = B, validator = function(self) cat("C ")) expect_snapshot({ . <- A() . <- B() . <- C() }) }) }) describe("S7 object", { it("has an S7 and S3 class", { foo <- new_class("foo", package = NULL) x <- foo() expect_equal(S7_class(x), foo) expect_equal(class(x), c("foo", "S7_object")) }) it("displays nicely", { expect_snapshot({ foo <- new_class("foo", properties = list(x = class_double, y = class_double), package = NULL) foo() str(list(foo())) }) }) it("displays objects with data nicely", { expect_snapshot({ text <- new_class("text", class_character, package = NULL) text("x") str(list(text("x"))) }) }) it("displays list objects nicely", { foo1 <- new_class( "foo1", parent = class_list, properties = list(x = class_double, y = class_list), package = NULL ) expect_snapshot( foo1( list( x = 1, y = list(a = 21, b = 22) ), x = 3, y = list(a = 41, b = 42) ) ) }) }) describe("default constructor", { it("initializes properties with defaults", { foo1 <- new_class("foo1", properties = list(x = class_double)) expect_equal(props(foo1()), list(x = double())) foo2 <- new_class("foo2", foo1, properties = list(y = class_double)) expect_equal(props(foo2()), list(x = double(), y = double())) }) it("overrides properties with arguments", { foo1 <- new_class("foo1", properties = list(x = class_double)) foo2 <- new_class("foo2", foo1, properties = list(y = class_double)) expect_equal(props(foo2(x = 1)), list(x = 1, y = double())) expect_equal(props(foo2(x = 1, y = 2)), list(x = 1, y = 2)) }) it("can initialise a property to NULL", { foo <- new_class("foo", properties = list( x = new_property(default = 10) )) x <- foo(x = NULL) expect_equal(x@x, NULL) }) it("initializes data with defaults", { text1 <- new_class("text1", parent = class_character) obj <- text1() expect_equal(S7_data(obj), character()) }) it("overrides data with defaults", { text1 <- new_class("text1", parent = class_character) expect_equal(S7_data(text1("x")), "x") }) it("initializes property with S7 object", { foo1 <- new_class("foo1", package = NULL) foo2 <- new_class("foo2", properties = list(x = foo1), package = NULL) x <- foo2() expect_s3_class(x@x, "foo1") }) }) test_that("c(, ...) gives error", { foo1 <- new_class("foo1") expect_snapshot(error = TRUE, { c(foo1, foo1) }) }) test_that("can round trip to disk and back", { eval(quote({ foo1 <- new_class("foo1", properties = list(y = class_integer)) foo2 <- new_class("foo2", properties = list(x = foo1)) f <- foo2(x = foo1(y = 1L)) }), globalenv()) f <- globalenv()[["f"]] path <- tempfile() saveRDS(f, path) f2 <- readRDS(path) expect_equal(f, f2) rm(foo1, foo2, f, envir = globalenv()) }) test_that("can't create class with reserved property names", { expect_snapshot(error = TRUE, { new_class("foo", properties = list(names = class_character)) new_class("foo", properties = list(dim = NULL | class_integer)) new_class("foo", properties = list(dim = NULL | class_integer, dimnames = class_list)) }) }) S7/tests/testthat/test-generic.R0000644000176200001440000000474514712423107016274 0ustar liggesuserstest_that("new_generic checks its inputs", { expect_snapshot(error = TRUE, { new_generic(1) new_generic("") new_generic("foo", 1) new_generic("foo", "x", function(x) {}) }) }) test_that("new_generic finds S7_dispatch calls", { expect_s3_class(new_generic("foo", "x", function(x) { S7_dispatch() }), "S7_generic") expect_s3_class(new_generic("foo", "x", function(x) { S7::S7_dispatch() }), "S7_generic") }) test_that("derived fun always includes ...", { g <- new_generic("g", "x") expect_equal(names(formals(g)), c("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(NA_character_) check_dispatch_args(c("x", "x")) check_dispatch_args("...") check_dispatch_args("y", function(x, ..., y) {}) }) }) test_that("S7_generic printing", { foo1 <- new_generic("foo1", "x") text <- new_class("text", package = NULL) method(foo1, class_character) <- function(x) 1 method(foo1, text) <- function(x) 2 foo3 <- new_generic("foo3", c("x", "y", "z")) method(foo3, list(class_character, text, class_character)) <- function(x, y, z, ...) 1 method(foo3, list(class_character, class_integer, class_character)) <- function(x, y, z, ...) 2 method(foo3, list(class_character, class_integer, class_logical)) <- function(x, y, z, ...) 3 expect_snapshot({ foo1 foo3 }) }) test_that("S7_generic printing with long / many arguments", { foo <- new_generic("foo", letters) expect_snapshot( foo ) }) # check_generic_fun ------------------------------------------------------- test_that("check_generic produces informative errors", { expect_snapshot(error = TRUE,{ check_generic("x") check_generic(function() {}) }) }) test_that("find_call handles expected cases", { expect_equal(find_call(1, quote(x)), NULL) expect_equal(find_call(quote(f()), quote(x)), NULL) expect_equal(find_call(quote(f(a, b, c)), quote(x)), NULL) expect_equal(find_call(quote(f()), quote(x), "ns.name"), NULL) expect_equal(find_call(quote(f(a, b, c)), quote(x), "ns.name"), NULL) expect_equal(find_call(quote(x(1)), quote(x)), quote(x(1))) expect_equal(find_call(quote(y(x(1))), quote(x)), quote(x(1))) expect_equal(find_call(quote(ns.name::x(1)), quote(x), "ns.name"), quote(ns.name::x(1))) expect_equal(find_call(quote(y(ns.name::x(1))), quote(x), "ns.name"), quote(ns.name::x(1))) }) S7/tests/testthat/helper.R0000644000176200001440000000657014712423107015160 0ustar liggesusersquick_install <- function(package, lib, quiet = TRUE) { opts <- c( "--data-compress=none", "--no-byte-compile", "--no-data", "--no-demo", "--no-docs", "--no-help", "--no-html", "--no-libs", "--use-vanilla", NULL ) for (p in package) { install.packages( pkgs = p, lib = lib, repos = NULL, type = "source", quiet = quiet, INSTALL_opts = paste(opts, collapse = " ") ) } } quick_test <- function() { identical(Sys.getenv("R_TESTTHAT_QUICK", "false"), "true") } quick_test_disable <- function() { Sys.setenv("R_TESTTHAT_QUICK" = "false") } quick_test_enable <- function() { Sys.setenv("R_TESTTHAT_QUICK" = "true") } scrub_environment <- function(x) { gsub("environment: 0x[0-9a-f]+", "environment: 0x0", x) } local_methods <- function(..., frame = parent.frame()) { generics <- list(...) methods <- lapply(generics, function(x) as.list(x@methods)) defer(for(i in seq_along(methods)) { env <- generics[[i]]@methods rm(list = ls(envir = env), envir = env) list2env(methods[[i]], envir = env) }, frame = frame) invisible() } local_S4_class <- function(name, ..., env = parent.frame()) { out <- methods::setClass(name , contains = "character") defer(S4_remove_classes(name, env), env) out } # Lightweight equivalent of withr::defer() defer <- function(expr, frame = parent.frame(), after = FALSE) { thunk <- as.call(list(function() expr)) do.call(on.exit, list(thunk, TRUE, after), envir = frame) } # always returns a named list, even in the empty case. named_list <- function(...) { x <- list(...) names(x) <- names2(x) x } `:=` <- function(sym, val) { cl <- sys.call() cl[[1L]] <- quote(`<-`) stopifnot(is.symbol(cl[[2L]]) && is.call(cl[[3L]])) cl[[3L]]$name <- as.character(cl[[2L]]) eval.parent(cl) } `add<-` <- `+` dbg <- function(..., .display = utils::str, .file = NULL) { out <- NULL exprs <- as.list(substitute(list(...)))[-1L] if (!is.null(.file)) { sink(.file, append = TRUE) on.exit(sink()) } for (i in seq_len(...length())) { ..i <- as.symbol(sprintf("..%i", i)) if (eval(substitute(missing(..i)))) { next } name <- names(exprs)[[i]] expr <- deparse1(exprs[[i]]) label <- if (is.null(name)) { sprintf("`%s`", expr) } else { sprintf("(%s) `%s`", name, expr) } cat(label, if (identical(.display, utils::str)) ": " else "\n", sep = "") .display(out <- eval(..i)) } cl <- sys.call() filepath <- utils::getSrcFilename(cl) if (length(filepath)) { if (!file.exists(filepath) && file.exists(file.path("R", filepath))) { filepath <- file.path("R", filepath) } lineno <- utils::getSrcLocation(cl) if (isNamespaceLoaded("cli")) { cli <- asNamespace("cli") loc <- cli$col_grey(cli$style_hyperlink( sprintf("(from %s:%i)", filepath, lineno), sprintf("file://%s", normalizePath(filepath, mustWork = FALSE)), params = c(line = lineno) )) } else { loc <- sprintf("(from %s:%i)", filepath, lineno) } cat(loc, "\n") } else { cat(sprintf("(from call: %s (srcfile missing))\n", trimws( deparse1(sys.call(-2) %error% sys.call(-1), width.cutoff = 60) ))) } invisible(out) } `%error%` <- function(x, y) tryCatch(x, error = function(e) y) drop_attributes <- function(x) { attributes(x) <- NULL x } S7/tests/testthat/test-class-spec.R0000644000176200001440000001604114712423107016705 0ustar liggesuserstest_that("can work with S7 classes", { klass <- new_class("klass", package = NULL) expect_equal(as_class(klass), klass) expect_equal(class_type(klass), "S7") expect_equal(class_dispatch(klass), c("klass", "S7_object")) expect_equal(class_register(klass), "klass") expect_equal(class_construct(klass), klass()) expect_equal(class_desc(klass), "") expect_equal(class_deparse(klass), "klass") obj <- klass() expect_equal(obj_type(obj), "S7") expect_equal(obj_desc(obj), "") expect_equal(obj_dispatch(obj), c("klass", "S7_object")) expect_equal(class_inherits(obj, klass), TRUE) }) test_that("can work with S7 classes in packages", { klass <- new_class("klass", package = "pkg") expect_equal(as_class(klass), klass) expect_equal(class_type(klass), "S7") expect_equal(class_dispatch(klass), c("pkg::klass", "S7_object")) expect_equal(class_register(klass), "pkg::klass") expect_equal(class_construct(klass), klass()) expect_equal(class_desc(klass), "") expect_equal(class_deparse(klass), "pkg::klass") obj <- klass() expect_equal(obj_type(obj), "S7") expect_equal(obj_desc(obj), "") expect_equal(obj_dispatch(obj), c("pkg::klass", "S7_object")) expect_equal(class_inherits(obj, klass), TRUE) }) test_that("can work with unions", { text <- new_class("text", class_character, package = NULL) number <- new_class("number", class_double, package = NULL) klass <- new_union(text, number) expect_equal(as_class(klass), klass) expect_equal(class_type(klass), "S7_union") expect_error(class_dispatch(klass), "Unsupported") expect_error(class_register(klass)) expect_equal(class_construct(klass), text()) expect_equal(class_desc(klass), " or ") expect_equal(class_deparse(klass), "new_union(text, number)") # Can't have an instance of a union so no obj_ tests expect_equal(class_inherits(text("x"), klass), TRUE) expect_equal(class_inherits(number(1), klass), TRUE) }) test_that("handles NULL", { expect_equal(as_class(NULL), NULL) expect_equal(class_type(NULL), "NULL") expect_equal(class_dispatch(NULL), "NULL") expect_equal(class_register(NULL), "NULL") expect_equal(class_construct(NULL), NULL) expect_equal(class_desc(NULL), "") expect_equal(class_deparse(NULL), "NULL") expect_equal(obj_type(NULL), "base") expect_equal(obj_desc(NULL), "") expect_equal(obj_dispatch(NULL), "NULL") expect_equal(class_inherits("x", NULL), FALSE) expect_equal(class_inherits(NULL, NULL), TRUE) }) # base -------------------------------------------------------------------- test_that("can work with base types", { klass <- class_character expect_equal(class_type(klass), "S7_base") expect_equal(class_dispatch(klass), c("character", "S7_object")) expect_equal(class_register(klass), "character") expect_equal(class_desc(klass), "") expect_equal(class_construct(klass, "x"), "x") expect_equal(class_deparse(klass), 'class_character') obj <- "x" expect_equal(obj_type(obj), "base") expect_equal(obj_desc(obj), "") expect_equal(obj_dispatch(obj), "character") expect_equal(class_inherits(obj, klass), TRUE) }) test_that("class_inherits handles variation in class names", { expect_true(class_inherits(1, class_double)) expect_false(class_inherits("x", class_double)) expect_true(class_inherits(1L, class_numeric)) expect_true(class_inherits(1, class_numeric)) expect_false(class_inherits("x", class_numeric)) expect_true(class_inherits(function() {}, class_function)) expect_true(class_inherits(sum, class_function)) expect_true(class_inherits(`[`, class_function)) expect_false(class_inherits("x", class_function)) }) test_that("dispatch for base objects use underlying type", { expect_equal(obj_dispatch(1), "double") expect_equal(obj_dispatch(1L), "integer") expect_equal(obj_dispatch(matrix(1)), "double") expect_equal(obj_dispatch(matrix(1L)), "integer") expect_equal(obj_dispatch(array(1)), "double") expect_equal(obj_dispatch(array(1L)), "integer") expect_equal(obj_dispatch(function() {}), "function") expect_equal(obj_dispatch(sum), "function") expect_equal(obj_dispatch(`[`), "function") expect_equal(obj_dispatch(quote({})), "call") }) # S3 ---------------------------------------------------------------------- test_that("can work with S3 classes", { klass <- new_S3_class(c("ordered", "factor"), constructor = function(.data = numeric(), levels) ordered(.data, levels) ) expect_equal(as_class(klass), klass) expect_equal(class_type(klass), "S7_S3") expect_equal(class_dispatch(klass), c("ordered", "factor", "S7_object")) expect_equal(class_register(klass), "ordered") expect_equal(class_desc(klass), "S3") expect_equal(class_construct(klass), ordered(numeric())) expect_equal(class_deparse(klass), 'new_S3_class(c("ordered", "factor"))') obj <- ordered(integer()) expect_equal(obj_type(obj), "S3") expect_equal(obj_desc(obj), "S3") expect_equal(obj_dispatch(obj), c("ordered", "factor")) expect_equal(class_inherits(obj, klass), TRUE) expect_equal(class_inherits(factor(), klass), FALSE) }) test_that("can work with S7 classes that extend S3 classes", { Date <- new_S3_class("Date", constructor = function(.data = numeric()) .Date(.data)) Date2 <- new_class("Date2", parent = Date, properties = list(x = class_numeric), package = NULL) expect_equal(class_type(Date2), "S7") expect_equal(class_dispatch(Date2), c("Date2", "Date", "S7_object")) expect_equal(class_register(Date2), "Date2") obj <- Date2(x = 1) expect_equal(obj_type(obj), "S7") expect_equal(obj_desc(obj), "") expect_equal(obj_dispatch(obj), c("Date2", "Date", "S7_object")) expect_equal(class_inherits(.Date(1), Date), TRUE) expect_equal(class_inherits(obj, Date), TRUE) expect_equal(class_inherits(obj, Date2), TRUE) }) # S4 ---------------------------------------------------------------------- test_that("can work with S4 classes", { on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3", "Foo4"))) methods::setClass("Foo1", contains = "character") methods::setClass("Foo2", contains = "Foo1") methods::setClass("Foo3", slots = list(x = "numeric")) methods::setClass("Foo4", contains = c("Foo2", "Foo3")) klass <- methods::getClass("Foo4") expect_equal(class_type(klass), "S4") expect_equal(class_dispatch(klass), c("S4/S7::Foo4", "S4/S7::Foo2", "S4/S7::Foo3", "S4/S7::Foo1", "character")) expect_equal(class_register(klass), "S4/S7::Foo4") expect_s4_class(class_construct(klass, 1, x = 2), "Foo4") expect_equal(class_desc(klass), "S4") expect_equal(class_deparse(klass), "Foo4") obj <- methods::new(klass, 1, x = 2) expect_equal(obj_type(obj), "S4") expect_equal(obj_desc(obj), "S4") expect_equal(obj_dispatch(obj), class_dispatch(klass)) expect_equal(class_inherits(obj, klass), TRUE) }) # input validation ------------------------------------------------------------- test_that("as_class gives informative errors", { expect_snapshot(error = TRUE, { as_class("foo") as_class(TRUE) }) }) S7/tests/testthat/test-method-register.R0000644000176200001440000001237214712423107017755 0ustar liggesusersdescribe("method registration", { it("adds methods to the generic", { foo <- new_generic("foo", "x") method(foo, class_character) <- function(x) "c" method(foo, class_integer) <- function(x) "i" expect_length(methods(foo), 2) }) it("adds messages when overwriting", { foo <- new_generic("foo", "x") expect_snapshot({ method(foo, class_character) <- function(x) "c" method(foo, class_character) <- function(x) "c" }) expect_length(methods(foo), 1) }) it("adds method for each element of a union", { foo <- new_generic("foo", "x") method(foo, class_numeric) <- function(x) "x" # one method for each union component expect_length(methods(foo), 2) # each method has the expected signature expect_equal(method(foo, class_integer)@signature, list(class_integer)) expect_equal(method(foo, class_double)@signature, list(class_double)) }) it("can register method for external generic", { bar <- new_class("bar") base_sum <- new_external_generic("base", "sum", "x") method(base_sum, bar) <- function(x, ...) "bar" expect_equal(sum(bar()), "bar") # and doesn't modify generic expect_equal(sum, base::sum) }) it("can register S7 method for S3 generic", { foo1 <- new_class("foo") method(sum, foo1) <- function(x, ...) "foo" expect_equal(sum(foo1()), "foo") foo2 <- new_class("foo", package = "bar") method(sum, foo2) <- function(x, ...) "foo" expect_equal(sum(foo2()), "foo") # and doesn't modify generic expect_equal(sum, base::sum) }) it("can register S7 method for S3 Ops generic", { foo <- new_class("foo") bar <- new_class("bar") method(`+`, list(foo, bar)) <- function(e1, e2) "foobar" expect_equal(foo() + bar(), "foobar") if(getRversion() >= "4.3.0") { method(`%*%`, list(foo, bar)) <- function(x, y) "foo.bar" expect_equal(foo() %*% bar(), "foo.bar") } }) it("S3 registration requires a S7 class", { foo <- new_class("foo") expect_snapshot(error = TRUE, { method(sum, new_S3_class("foo")) <- function(x, ...) "foo" }) }) it("can register S7 method for S4 generic", { methods::setGeneric("bar", function(x) standardGeneric("bar")) S4foo <- new_class("S4foo", package = NULL) expect_snapshot_error(method(bar, S4foo) <- function(x) "foo") S4_register(S4foo) on.exit(S4_remove_classes("S4foo"), add = TRUE) method(bar, S4foo) <- function(x) "foo" expect_equal(bar(S4foo()), "foo") }) it("checks argument types", { foo <- new_generic("foo", "x") expect_snapshot(error = TRUE, { x <- 10 method(x, class_character) <- function(x) ... method(foo, 1) <- function(x) ... }) }) }) describe("as_signature()", { it("returns a list that matches length of dispatch args", { foo1 <- new_generic("foo1", "x") sig1 <- as_signature(class_numeric, foo1) expect_s3_class(sig1, "S7_signature") expect_length(sig1, 1) foo2 <- new_generic("foo2", c("x", "y")) sig2 <- as_signature(list(class_numeric, class_character), foo2) expect_s3_class(sig1, "S7_signature") expect_length(sig2, 2) }) it("is idempotent", { expect_equal(as_signature(new_signature(10)), new_signature(10)) }) it("forbids list for single dispatch", { foo <- new_generic("foo", "x") expect_snapshot(as_signature(list(1), foo), error = TRUE) }) it("requires a list of the correct length for multiple dispatch", { foo <- new_generic("foo", c("x", "y")) expect_snapshot(error = TRUE, { as_signature(class_character, foo) as_signature(list(class_character), foo) }) }) it("works with NULL", { foo <- new_generic("foo", c("x")) sig <- as_signature(NULL, foo) expect_length(sig, 1) foo <- new_generic("foo", c("x", "y", "z")) sig <- as_signature(list(NULL, NULL, class_integer), foo) expect_length(sig, 3) }) }) test_that("check_method returns TRUE if the functions are compatible", { foo <- new_generic("foo", "x", function(x, ...) S7_dispatch()) expect_true(check_method(function(x, ...) x, foo)) # extra arguments are ignored expect_true(check_method(function(x, ..., y) x, foo)) foo <- new_generic("foo", "x", function(x) S7_dispatch()) expect_true(check_method(function(x) x, foo)) }) test_that("check_method complains if the functions are not compatible", { expect_snapshot(error = TRUE, { foo <- new_generic("foo", "x") check_method(1, foo) check_method(function(y) {}, foo) check_method(function(x = "foo") {}, foo) check_method(function(x, y, ...) {}, foo) }) expect_snapshot(error = TRUE, { foo <- new_generic("foo", "x", function(x) S7_dispatch()) check_method(function(x, y) {}, foo) }) }) test_that("check_method warn if default arguments don't match", { expect_snapshot({ foo <- new_generic("foo", "x", function(x, ..., z = 2, y = 1) S7_dispatch()) check_method(function(x, ..., y = 1) {}, foo) check_method(function(x, ..., y = 1, z = 1) {}, foo) }) }) test_that("S7_method printing", { foo <- new_generic("foo", c("x", "y")) method(foo, list(class_integer, class_integer)) <- function(x, y, ...) paste0("bar:", x, y) expect_snapshot( method(foo, list(class_integer, class_integer)), transform = scrub_environment ) }) S7/tests/testthat/test-zzz.R0000644000176200001440000000222514712423107015504 0ustar liggesuserstest_that("S7_class validates its underlying data", { x <- new_class("X", package = NULL)() expect_snapshot_error(S7_data(x) <- 1) }) test_that("$ gives useful error", { foo <- new_class("foo") x <- foo() expect_snapshot(error = TRUE, { x$y x$y <- 1 }) # But works as expected if inheriting from list foo <- new_class("foo", class_list) x <- foo() x$x <- 1 expect_equal(x$x, 1) }) test_that("[ gives more accurate error", { expect_snapshot(error = TRUE, { x <- new_class("foo")() x[1] x[1] <- 1 }) # but ok if inheriting from list x <- new_class("foo", class_list)() x[1] <- 1 expect_equal(x[1], list(1)) }) test_that("[[ gives more accurate error", { expect_snapshot(error = TRUE, { x <- new_class("foo")() x[[1]] x[[1]] <- 1 }) # but ok if inheriting from list x <- new_class("foo", class_list)() x[[1]] <- 1 expect_equal(x[[1]], 1) }) test_that("register S4 classes for key components", { expect_s4_class(getClass("S7_object"), "classRepresentation") expect_s4_class(getClass("S7_method"), "classRepresentation") expect_s4_class(getClass("S7_generic"), "classRepresentation") }) S7/tests/testthat/t2/0000755000176200001440000000000014712423107014073 5ustar liggesusersS7/tests/testthat/t2/R/0000755000176200001440000000000014712423107014274 5ustar liggesusersS7/tests/testthat/t2/R/t2.R0000644000176200001440000000200414712423107014740 0ustar liggesusers #' @export an_s7_class <- S7::new_class("an_s7_class") #' @importFrom t0 an_s7_generic S7::method(an_s7_generic, S7::class_character) <- function(x) "foo" S7::method(an_s7_generic, an_s7_class) <- function(x) "foo" #' @importFrom t0 an_s3_generic S7::method(an_s3_generic, an_s7_class) <- function(x) "foo" #' @rawNamespace importFrom(t0, `An S7 Class`) #' @export `An S7 Class 2` <- S7::new_class("An S7 Class 2", properties = list(bar = `An S7 Class`)) NULL `An Internal Class` <- S7::new_class("An Internal Class", properties = list( foo = `An S7 Class`, bar = `An S7 Class 2` )) another_s7_generic <- S7::new_external_generic("t1", "another_s7_generic", "x") S7::method(another_s7_generic, S7::class_character) <- function(x) "foo" S7::method(another_s7_generic, an_s7_class) <- function(x) "foo" another_s3_generic <- S7::new_external_generic("t1", "another_s3_generic", "x") S7::method(another_s3_generic, an_s7_class) <- function(x) "foo" .onLoad <- function(libname, pkgname) { S7::methods_register() } S7/tests/testthat/t2/NAMESPACE0000644000176200001440000000026214712423107015312 0ustar liggesusers# Generated by roxygen2: do not edit by hand export("An S7 Class 2") export(an_s7_class) importFrom(t0, `An S7 Class`) importFrom(t0,an_s3_generic) importFrom(t0,an_s7_generic) S7/tests/testthat/t2/DESCRIPTION0000644000176200001440000000105714703771245015615 0ustar liggesusersPackage: t2 Title: What the Package Does (One Line, Title Case) Version: 0.0.0.9000 Authors@R: c(person(given = "Jim", family = "Hester", role = c("aut", "cre"), email = "james.f.hester@gmail.com", comment = c(ORCID = "0000-0002-2739-7082")), person(given = "RStudio", role = c("cph", "fnd"))) Description: What the package does (one paragraph). Imports: S7, t0 Suggests: t1 License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 S7/tests/testthat/test-special.R0000644000176200001440000000051414477643271016304 0ustar liggesuserstest_that("can test and print", { expect_true(is_class_missing(class_missing)) expect_false(is_class_missing(class_any)) expect_true(is_class_any(class_any)) expect_false(is_class_any(class_missing)) expect_snapshot({ print(class_missing) print(class_any) str(list(m = class_missing, a = class_any)) }) }) S7/tests/testthat/test-data.R0000644000176200001440000000123114477643271015572 0ustar liggesusersdescribe("S7_data", { text <- new_class("text", class_character) it("retrieves .data", { x <- text("hi") expect_equal(S7_data(x), "hi") }) it("strips properties", { text <- new_class("text", class_character, properties = list(x = class_integer)) x <- text("hi", x = 10L) expect_equal(attributes(S7_data(x)), NULL) }) it("preserves non-property attributes when retrieving .data", { val <- c(foo = "hi", bar = "ho") expect_equal(names(S7_data(text(val))), names(val)) }) it("lets you set data", { val <- c(foo = "hi", bar = "ho") x <- text("foo") S7_data(x) <- "bar" expect_equal(S7_data(x), "bar") }) }) S7/tests/testthat/test-external-generic.R0000644000176200001440000001032714712423107020105 0ustar liggesuserstest_that("can get and append methods", { external_methods_reset("S7") on.exit(external_methods_reset("S7"), add = TRUE) expect_equal(S7_methods_table("S7"), list()) bar <- new_external_generic("foo", "bar", "x") external_methods_add("S7", bar, list(), function() {}) expect_equal( S7_methods_table("S7"), list( list( generic = bar, signature = list(), method = function() {} ) ) ) }) test_that("displays nicely", { bar <- new_external_generic("foo", "bar", "x") on.exit(external_methods_reset("S7"), add = TRUE) expect_snapshot({ print(bar) }) }) test_that("can convert existing generics to external", { foo_S7 <- new_generic("foo_S7", "x") env <- new.env() env$.packageName <- "test" environment(foo_S7) <- env expect_equal( as_external_generic(foo_S7), new_external_generic("test", "foo_S7", "x") ) foo_ext <- new_external_generic("pkg", "foo", "x") expect_equal(as_external_generic(foo_ext), foo_ext) expect_equal( as_external_generic(as_S3_generic(sum)), new_external_generic("base", "sum", "__S3__") ) methods::setGeneric("foo_S4", function(x) {}) expect_equal( as_external_generic(foo_S4), new_external_generic("S7", "foo_S4", "x") ) }) test_that("new_method works with both hard and soft dependencies", { # NB: Relies on installed S7 skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") skip_if(quick_test()) on.exit({ .libPaths(old_libpaths) try(detach("package:t2", unload = TRUE), silent = TRUE) try(detach("package:t1", unload = TRUE), silent = TRUE) try(detach("package:t0", unload = TRUE), silent = TRUE) unlink(tmp_lib, recursive = TRUE) # remove.packages(c("t1", "t0", "t2")) }) tmp_lib <- tempfile() dir.create(tmp_lib) old_libpaths <- .libPaths() .libPaths(c(tmp_lib, old_libpaths)) # t2 has a hard dependency on t0 # t2 has a soft dependency on t1 # First, ensure that t2 can install and run successfully without t1 installed quick_install(test_path("t0"), tmp_lib) quick_install(test_path("t2"), tmp_lib) library("t2") library("t0") expect_equal(an_s3_generic(t2::an_s7_class()), "foo") expect_equal(an_s7_generic("x"), "foo") # test that new_class() will construct a property default as a namespaced call # to t0::AnS7Class() (and not inline the full class object). # As these tests grow, consider splitting this into a separate context like: # test_that("package exported classes are not inlined in constructor formals", {...}) Foo <- new_class("Foo", properties = list(bar = t0::`An S7 Class`)) expect_identical(formals(Foo) , as.pairlist(alist(bar = t0::`An S7 Class`()))) expect_identical(formals(t2::`An S7 Class 2`), as.pairlist(alist(bar = t0::`An S7 Class`()))) expect_identical(formals(t2:::`An Internal Class`), as.pairlist(alist( foo = t0::`An S7 Class`(), bar = `An S7 Class 2`() ))) expect_snapshot({ args(Foo) args(t2::`An S7 Class 2`) args(t2:::`An Internal Class`) }) # test we emit informative error messages if a new_class() call with an # external class dependency is malformed. # https://github.com/RConsortium/S7/issues/477 expect_snapshot(error = TRUE, { new_class("Foo", properties = list( bar = new_class("Made Up Class", package = "t0") )) new_class("Foo", properties = list( bar = new_class("Made Up Class", package = "Made Up Package") )) modified_class <- t0::`An S7 Class` attr(modified_class, "xyz") <- "abc" new_class("Foo", properties = list(bar = modified_class)) }) # Now install the soft dependency quick_install(test_path("t1"), tmp_lib) library("t1") expect_equal(another_s3_generic(t2::an_s7_class()), "foo") expect_equal(another_s7_generic("x"), "foo") ## Check again in a fresh session, with everything installed expect_no_error(callr::r(function() { library(t2) stopifnot(exprs = { t0::an_s3_generic(an_s7_class()) == "foo" t0::an_s7_generic("x") == "foo" }) if(isNamespaceLoaded("t1")) stop("Prematurely loaded {t1}") stopifnot(exprs = { t1::another_s3_generic(an_s7_class()) == "foo" t1::another_s7_generic("x") == "foo" }) NULL })) }) S7/tests/testthat/_snaps/0000755000176200001440000000000014712423107015031 5ustar liggesusersS7/tests/testthat/_snaps/convert.md0000644000176200001440000000034714712243611017037 0ustar liggesusers# can register convert methods Code convert(obj, to = class_double) Condition Error: ! Can't find method for generic `convert()` with dispatch classes: - from: - to : S7/tests/testthat/_snaps/base.md0000644000176200001440000000051114704005260016257 0ustar liggesusers# validation uses typeof Code class_integer$validator(TRUE) Output [1] "Underlying data must be not " # base class display as expected Code class_integer Output : Code str(class_integer) Output : S7/tests/testthat/_snaps/method-register.md0000644000176200001440000000640114712423107020456 0ustar liggesusers# method registration: adds messages when overwriting Code method(foo, class_character) <- (function(x) "c") method(foo, class_character) <- (function(x) "c") Message Overwriting method foo() # method registration: S3 registration requires a S7 class Code method(sum, new_S3_class("foo")) <- (function(x, ...) "foo") Condition Error: ! When registering methods for S3 generic sum(), signature must be an S7 class, not an S3 class. # method registration: can register S7 method for S4 generic Class has not been registered with S4; please call S4_register(S4foo) # method registration: checks argument types Code x <- 10 method(x, class_character) <- (function(x) ...) Condition Error: ! `generic` must be a function, not a Code method(foo, 1) <- (function(x) ...) Condition Error: ! Can't convert `signature` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . # as_signature(): forbids list for single dispatch Code as_signature(list(1), foo) Condition Error: ! Can't convert `signature` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . # as_signature(): requires a list of the correct length for multiple dispatch Code as_signature(class_character, foo) Condition Error: ! `signature` must be a list for multidispatch generics Code as_signature(list(class_character), foo) Condition Error: ! `signature` must be length 2 # check_method complains if the functions are not compatible Code foo <- new_generic("foo", "x") check_method(1, foo) Condition Error: ! foo(???) must be a function Code check_method(function(y) { }, foo) Condition Error: ! foo() dispatches on `x`, but foo(???) has arguments `y` Code check_method(function(x = "foo") { }, foo) Condition Error: ! In foo(???), dispatch arguments (`x`) must not have default values Code check_method(function(x, y, ...) { }, foo) --- Code foo <- new_generic("foo", "x", function(x) S7_dispatch()) check_method(function(x, y) { }, foo) Condition Error: ! foo() generic lacks `...` so method formals must match generic formals exactly. - generic formals: foo(x) - method formals: foo(x, y) # check_method warn if default arguments don't match Code foo <- new_generic("foo", "x", function(x, ..., z = 2, y = 1) S7_dispatch()) check_method(function(x, ..., y = 1) { }, foo) Condition Warning: foo(???) doesn't have argument `z` Code check_method(function(x, ..., y = 1, z = 1) { }, foo) Condition Warning: In foo(???), default value of `z` is not the same as the generic - Generic: 2 - Method: 1 # S7_method printing Code method(foo, list(class_integer, class_integer)) Output method(foo, list(class_integer, class_integer)) function (x, y, ...) paste0("bar:", x, y) S7/tests/testthat/_snaps/S4.md0000644000176200001440000000027114704005261015637 0ustar liggesusers# errors on non-S4 classes Code S4_to_S7_class(1) Condition Error: ! Unsupported S4 object: must be a class generator or a class definition, not a . S7/tests/testthat/_snaps/union.md0000644000176200001440000000103014712423107016475 0ustar liggesusers# has useful print method Code foo1 <- new_class("foo1", package = NULL) foo2 <- new_class("foo2", package = NULL) new_union(foo1, foo2) Output : or # base unions display as expected Code class_vector Output : , , , , , , , or Code str(class_vector) Output : , , , , , , , or S7/tests/testthat/_snaps/method-dispatch.md0000644000176200001440000000327114712423107020433 0ustar liggesusers# generics pass ... to methods unused argument (z = 2) # single dispatch fails with informative messages Code fail(TRUE) Condition Error: ! Can't find method for `fail()`. Code fail(tibble::tibble()) Condition Error: ! Can't find method for `fail(S3)`. Code fail(foo()) Condition Error: ! Can't find method for `fail()`. Code fail(Foo(x = 1)) Condition Error: ! Can't find method for `fail(S4)`. # multiple dispatch fails with informative messages Code fail(TRUE) Condition Error: ! Can't find method for generic `fail(x, y)`: - x: - y: MISSING Code fail(, TRUE) Condition Error: ! Can't find method for generic `fail(x, y)`: - x: MISSING - y: Code fail(TRUE, TRUE) Condition Error: ! Can't find method for generic `fail(x, y)`: - x: - y: # method dispatch works for class_missing Code foo_wrapper() Condition Error in `foo_wrapper()`: ! argument "xx" is missing, with no default # errors from dispatched methods have reasonable tracebacks Code my_generic(10) Output [[1]] my_generic(10) [[2]] S7::S7_dispatch() [[3]] `method(my_generic, class_double)`(x = 10, ...) --- Code my_generic(3, 4) Output [[1]] my_generic(3, 4) [[2]] S7::S7_dispatch() [[3]] `method(my_generic, list(class_double, class_double))`(x = 3, y = 4, ...) S7/tests/testthat/_snaps/method-introspect.md0000644000176200001440000000404114712243611021022 0ustar liggesusers# method introspection: errors on invalid inputs Code method(print, 1) Condition Error: ! `generic` must be a , not a Code foo <- new_generic("foo", "x") method(foo) Condition Error: ! Must supply exactly one of `class` and `object` Code method(foo, 1) Condition Error: ! Can't convert `signature` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . Code method(foo, new_union(class_integer, class_double)) Condition Error in `as_dispatch()`: ! Can't dispatch on unions; must be a concrete type Code foo2 <- new_generic("foo2", c("x", "y")) method(foo2, object = list(class_character)) Condition Error: ! `object` must be length 2 # method introspection: errors if no method found Code method(foo, class = class_integer) Condition Error: ! Can't find method for `foo()`. Code method(foo, object = 1L) Condition Error: ! Can't find method for `foo()`. Code method(foo2, class = list(class_integer, class_double)) Condition Error: ! Can't find method for generic `foo(x, y)`: - x: - y: Code method(foo2, object = list(1L, 2)) Condition Error: ! Can't find method for generic `foo(x, y)`: - x: - y: # method explanation: shows all possible methods along with matches add([foo2], [foo2]) -> add([foo2], [foo1]) add([foo2], [S7_object]) add([foo2], [ANY]) add([foo1], [foo2]) * add([foo1], [foo1]) add([foo1], [S7_object]) add([foo1], [ANY]) add([S7_object], [foo2]) add([S7_object], [foo1]) add([S7_object], [S7_object]) add([S7_object], [ANY]) add([ANY], [foo2]) add([ANY], [foo1]) add([ANY], [S7_object]) add([ANY], [ANY]) S7/tests/testthat/_snaps/zzz.md0000644000176200001440000000165714712423107016221 0ustar liggesusers# S7_class validates its underlying data object is invalid: - Underlying data is corrupt # $ gives useful error Code x$y Condition Error: ! Can't get S7 properties with `$`. Did you mean `x@y`? Code x$y <- 1 Condition Error: ! Can't set S7 properties with `$`. Did you mean `...@y <- 1`? # [ gives more accurate error Code x <- new_class("foo")() x[1] Condition Error in `check_subsettable()`: ! S7 objects are not subsettable. Code x[1] <- 1 Condition Error in `check_subsettable()`: ! S7 objects are not subsettable. # [[ gives more accurate error Code x <- new_class("foo")() x[[1]] Condition Error in `check_subsettable()`: ! S7 objects are not subsettable. Code x[[1]] <- 1 Condition Error in `check_subsettable()`: ! S7 objects are not subsettable. S7/tests/testthat/_snaps/R-lt-4-3/0000755000176200001440000000000014712423107016150 5ustar liggesusersS7/tests/testthat/_snaps/R-lt-4-3/method-dispatch.md0000644000176200001440000000025514712423107021551 0ustar liggesusers# method dispatch works for class_missing Code foo_wrapper() Condition Error in `S7::S7_dispatch()`: ! argument "xx" is missing, with no default S7/tests/testthat/_snaps/inherits.md0000644000176200001440000000101514712423107017175 0ustar liggesusers# checks that input is a class Code S7_inherits(1:10, "x") Condition Error in `S7_inherits()`: ! `class` must be an or NULL # throws informative error Code foo1 <- new_class("foo1", package = NULL) foo2 <- new_class("foo2", package = NULL) check_is_S7(foo1(), foo2) Condition Error: ! `foo1()` must be a , not a --- Code check_is_S7("a") Condition Error: ! `"a"` must be an , not a S7/tests/testthat/_snaps/class-spec.md0000644000176200001440000000100614704005260017402 0ustar liggesusers# as_class gives informative errors Code as_class("foo") Condition Error: ! Can't convert `"foo"` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . Code as_class(TRUE) Condition Error: ! Can't convert `TRUE` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . S7/tests/testthat/_snaps/S3.md0000644000176200001440000000410614712243611015641 0ustar liggesusers# new_S3_class has a print method Code new_S3_class(c("ordered", "factor")) Output : S3 # subclasses inherit validator Code foo2("a") Condition Error: ! object is invalid: - Underlying data must be a double # new_S3_class() checks its inputs Code new_S3_class(1) Condition Error: ! `class` must be a character vector --- Code new_S3_class("foo", function(x) { }) Condition Error: ! First argument to `constructor` must be .data Code new_S3_class("foo", function(.data, ...) { }) Condition Error: ! `constructor` can not use `...` # default new_S3_class constructor errors Code class_construct(new_S3_class("foo"), 1) Condition Error: ! S3 class doesn't have a constructor # catches invalid factors Code validate_factor(structure("x")) Output [1] "Underlying data must be an " [2] "attr(, 'levels') must be a " [3] "Not enough 'levels' for underlying data" # catches invalid dates Code validate_date("x") Output [1] "Underlying data must be numeric" [2] "Underlying data must have class 'Date'" # catches invalid POSIXct Code validate_POSIXct(structure("x", tz = "UTC")) Output [1] "Underlying data must be numeric" Code validate_POSIXct(structure(1, tz = 1)) Output [1] "attr(, 'tz') must be a single string" # catches invalid data.frame Code validate_data.frame(1) Output [1] "Underlying data must be a " Code validate_data.frame(structure(list(x = 1, y = 1:2), row.names = 1L)) Output [1] "All columns and row names must have the same length" Code validate_data.frame(structure(list(x = 1, y = 1), row.names = 1:2)) Output [1] "All columns and row names must have the same length" Code validate_data.frame(structure(list(1), row.names = 1L)) Output [1] "Underlying data must be named" S7/tests/testthat/_snaps/property.md0000644000176200001440000001334514712243611017245 0ustar liggesusers# property retrieval: retrieves the properties that exist & errors otherwise Can't find property @x --- Can't find property @x # prop setting: can't set read-only properties Code obj@x <- 1 Condition Error: ! Can't set read-only property @x # prop setting: errors if the property doesn't exist or is wrong class Code obj <- foo(123) obj@foo <- 10 Condition Error: ! Can't find property @foo Code obj@x <- "x" Condition Error: ! @x must be , not # prop setting: validates all attributes if custom setter Code obj <- foo(y = 123, x = 123) obj@x <- "x" Condition Error: ! @y must be , not # new_property(): validates getter and settor Code new_property(getter = function(x) { }) Condition Error: ! `getter` must be function(self), not function(x) Code new_property(setter = function(x, y, z) { }) Condition Error: ! `setter` must be function(self, value), not function(x, y, z) # new_property(): validates default Code new_property(class_integer, default = "x") Condition Error in `new_property()`: ! `default` must be an instance of , not a # new_property(): displays nicely Code print(x) Output $ name : chr "foo" $ class : : $ getter : NULL $ setter : NULL $ validator: NULL $ default : NULL Code str(list(x)) Output List of 1 $ : ..$ name : chr "foo" ..$ class : : ..$ getter : NULL ..$ setter : NULL ..$ validator: NULL ..$ default : NULL # properties can be base, S3, S4, S7, or S7 union Code my_class Output class @ parent : @ constructor: function(anything, null, base, S3, S4, S7, S7_union) {...} @ validator : @ properties : $ anything: $ null : $ base : $ S3 : S3 $ S4 : S4 $ S7 : $ S7_union: or --- Code my_obj@null <- "x" Condition Error: ! @null must be , not Code my_obj@base <- "x" Condition Error: ! @base must be , not Code my_obj@S3 <- "x" Condition Error: ! @S3 must be S3, not Code my_obj@S4 <- "x" Condition Error: ! @S4 must be S4, not Code my_obj@S7 <- "x" Condition Error: ! @S7 must be , not Code my_obj@S7_union <- "x" Condition Error: ! @S7_union must be or , not # as_properties() gives useful error messages Code as_properties(1) Condition Error: ! `properties` must be a list Code as_properties(list(1)) Condition Error: ! `properties[[1]]` must be named. Code as_properties(list(new_property(class_character))) Condition Error: ! `properties[[1]]` must have a name or be named. Code as_properties(list(x = 1)) Condition Error: ! Can't convert `property$x` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . Code as_properties(list(x = class_character, x = class_character)) Condition Error: ! `properties` names must be unique # can validate with custom validator Code f <- foo(x = 1L) f@x <- 1:2 Condition Error: ! @x must be length 1 Code foo(x = 1:2) Condition Error: ! object properties are invalid: - @x must be length 1 # prop<- won't infinitly recurse on a custom setter Code obj <- foo() Output Starting syncup with value: setting @a <- "a_" setting @b <- "b_" Starting syncup with value: b_ setting @a <- "a_b_" setting @b <- "b_b_" Starting syncup with value: setting @a <- "a_" Starting syncup with value: a_ setting @a <- "a_a_" setting @b <- "b_a_" setting @b <- "b_" Code obj@a <- "val" Output Starting syncup with value: val setting @a <- "a_val" setting @b <- "b_val" Starting syncup with value: b_val setting @a <- "a_b_val" setting @b <- "b_b_val" # custom setters can invoke setters on non-self objects Code receiver <- Receiver() Output [rx] receiving: [rx] finished receiving. Code transmitter <- Transmitter() Output [tx] sending: [rx] receiving: [rx] finished receiving. [tx] saving last sent message. [tx] finished transmitting. Code transmitter@message <- "hello" Output [tx] sending: hello [rx] receiving: hello [rx] finished receiving. [tx] saving last sent message. [tx] finished transmitting. Code expect_equal(receiver@message, "hello") transmitter@message <- "goodbye" Output [tx] sending: goodbye [rx] receiving: goodbye [rx] finished receiving. [tx] saving last sent message. [tx] finished transmitting. Code expect_equal(receiver@message, "goodbye") S7/tests/testthat/_snaps/special.md0000644000176200001440000000042714704005261016774 0ustar liggesusers# can test and print Code print(class_missing) Output Code print(class_any) Output Code str(list(m = class_missing, a = class_any)) Output List of 2 $ m: $ a: S7/tests/testthat/_snaps/class.md0000644000176200001440000001345714712423107016472 0ustar liggesusers# S7 classes: print nicely Code foo2 Output class @ parent : @ constructor: function(x, y) {...} @ validator : @ properties : $ x: $ y: Code str(foo2) Output constructor @ name : chr "foo2" @ parent : constructor @ package : NULL @ properties :List of 2 .. $ x: .. ..$ name : chr "x" .. ..$ class : : .. ..$ getter : NULL .. ..$ setter : NULL .. ..$ validator: NULL .. ..$ default : NULL .. $ y: .. ..$ name : chr "y" .. ..$ class : : .. ..$ getter : NULL .. ..$ setter : NULL .. ..$ validator: NULL .. ..$ default : NULL @ abstract : logi FALSE @ constructor: function (x = integer(0), y = integer(0)) @ validator : NULL Code str(list(foo2)) Output List of 1 $ : constructor # S7 classes: prints @package and @abstract details Code foo Output abstract class @ parent : @ constructor: function() {...} @ validator : @ properties : # S7 classes: checks inputs Code new_class(1) Condition Error: ! `name` must be a single string Code new_class("foo", 1) Condition Error: ! Can't convert `parent` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . Code new_class("foo", package = 1) Condition Error: ! `package` must be a single string Code new_class("foo", constructor = 1) Condition Error: ! `constructor` must be a function Code new_class("foo", constructor = function() { }) Condition Error: ! `constructor` must contain a call to `new_object()` Code new_class("foo", validator = function() { }) Condition Error: ! `validator` must be function(self), not function() # S7 classes: can't inherit from S4 or class unions Code new_class("test", parent = parentS4) Condition Error: ! `parent` must be an S7 class, S3 class, or base type, not an S4 class. Code new_class("test", parent = new_union("character")) Condition Error: ! Can't convert `X[[i]]` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . # S7 classes: can't inherit from an environment Code new_class("test", parent = class_environment) Condition Error: ! Can't inherit from an environment. # abstract classes: can't be instantiated Code foo <- new_class("foo", abstract = TRUE) foo() Condition Error in `S7::new_object()`: ! Can't construct an object from abstract class # abstract classes: can't inherit from concrete class Code foo1 <- new_class("foo1") new_class("foo2", parent = foo1, abstract = TRUE) Condition Error in `new_class()`: ! Abstract classes must have abstract parents # abstract classes: can use inherited validator from abstract class Code foo2(x = 2) Condition Error: ! object is invalid: - @x has bad value # new_object(): gives useful error if called directly Code new_object() Condition Error in `new_object()`: ! `new_object()` must be called from within a constructor # new_object(): validates object Code foo("x") Condition Error: ! object properties are invalid: - @x must be , not Code foo(-1) Condition Error: ! object is invalid: - x must be positive # new_object(): runs each parent validator exactly once Code . <- A() Output A Code . <- B() Output A B Code . <- C() Output A B C # S7 object: displays nicely Code foo <- new_class("foo", properties = list(x = class_double, y = class_double), package = NULL) foo() Output @ x: num(0) @ y: num(0) Code str(list(foo())) Output List of 1 $ : ..@ x: num(0) ..@ y: num(0) # S7 object: displays objects with data nicely Code text <- new_class("text", class_character, package = NULL) text("x") Output chr "x" Code str(list(text("x"))) Output List of 1 $ : chr "x" # S7 object: displays list objects nicely Code foo1(list(x = 1, y = list(a = 21, b = 22)), x = 3, y = list(a = 41, b = 42)) Output List of 2 $ x: num 1 $ y:List of 2 ..$ a: num 21 ..$ b: num 22 @ x: num 3 @ y:List of 2 .. $ a: num 41 .. $ b: num 42 # c(, ...) gives error Code c(foo1, foo1) Condition Error: ! Can not combine S7 class objects # can't create class with reserved property names Code new_class("foo", properties = list(names = class_character)) Condition Error in `new_class()`: ! property can't be named: names Code new_class("foo", properties = list(dim = NULL | class_integer)) Condition Error in `new_class()`: ! property can't be named: dim Code new_class("foo", properties = list(dim = NULL | class_integer, dimnames = class_list)) Condition Error in `new_class()`: ! property can't be named: dim, dimnames S7/tests/testthat/_snaps/super.md0000644000176200001440000000063014712423107016510 0ustar liggesusers# super(): checks to Code foo <- new_class("foo", package = NULL) super(foo(), class_character) Condition Error in `super()`: ! doesn't inherit from # super(): displays nicely Code f1 <- super(foo2(), foo1) f1 Output super(, ) Code str(list(f1)) Output List of 1 $ : super(, ) S7/tests/testthat/_snaps/external-generic.md0000644000176200001440000000225214712423107020610 0ustar liggesusers# displays nicely Code print(bar) Output foo::bar(x) # new_method works with both hard and soft dependencies Code args(Foo) Output function (bar = t0::`An S7 Class`()) NULL Code args(t2::`An S7 Class 2`) Output function (bar = t0::`An S7 Class`()) NULL Code args(t2:::`An Internal Class`) Output function (foo = t0::`An S7 Class`(), bar = `An S7 Class 2`()) NULL --- Code new_class("Foo", properties = list(bar = new_class("Made Up Class", package = "t0"))) Condition Error: ! 'Made Up Class' is not an exported object from 'namespace:t0' Code new_class("Foo", properties = list(bar = new_class("Made Up Class", package = "Made Up Package"))) Condition Error in `loadNamespace()`: ! there is no package called 'Made Up Package' Code modified_class <- t0::`An S7 Class` attr(modified_class, "xyz") <- "abc" new_class("Foo", properties = list(bar = modified_class)) Condition Error: ! `t0::An S7 Class` is not identical to the class with the same @package and @name properties S7/tests/testthat/_snaps/constructor.md0000644000176200001440000000422014704005260017733 0ustar liggesusers# generates meaningful constructors Code new_constructor(S7_object, list()) Output function () { new_object(S7_object()) } Code new_constructor(S7_object, as_properties(list(x = class_numeric, y = class_numeric))) Output function (x = integer(0), y = integer(0)) { x y new_object(S7_object(), x = x, y = y) } Code foo <- new_class("foo", parent = class_character) new_constructor(foo, list()) Output function (.data = character(0)) new_object(foo(.data = .data)) Code foo2 <- new_class("foo2", parent = foo) new_constructor(foo2, list()) Output function (.data = character(0)) new_object(foo2(.data = .data)) # can generate constructors for S3 classes Code new_constructor(class_factor, list()) Output function (.data = integer(), levels = NULL) new_object(new_factor(.data = .data, levels = levels)) Code new_constructor(class_factor, as_properties(list(x = class_numeric, y = class_numeric))) Output function (.data = integer(), levels = NULL, x = integer(0), y = integer(0)) new_object(new_factor(.data = .data, levels = levels), x = x, y = y) # can generate constructor for inherited abstract classes Code foo1 <- new_class("foo1", abstract = TRUE, properties = list(x = class_double)) new_constructor(foo1, list()) Output function () { new_object(S7_object()) } Code new_constructor(foo1, as_properties(list(y = class_double))) Output function (y = numeric(0)) { y new_object(S7_object(), y = y) } # can use `...` in parent constructor Code new_constructor(foo, list(y = class_double)) Output function (..., y = numeric(0)) new_object(foo(...), y = y) S7/tests/testthat/_snaps/valid.md0000644000176200001440000000220214712243611016446 0ustar liggesusers# validate() validates object and type recursively Code obj <- klass(1, -1) attr(obj, "x") <- -1 validate(obj) Condition Error: ! object is invalid: - x must be positive Code attr(obj, "x") <- "y" validate(obj) Condition Error: ! object properties are invalid: - @x must be , not --- Code obj <- klass2(1, -1, 1) attr(obj, "x") <- -1 validate(obj) Condition Error: ! object is invalid: - x must be positive Code attr(obj, "x") <- "y" attr(obj, "z") <- "y" validate(obj) Condition Error: ! object properties are invalid: - @x must be , not - @z must be , not # validate checks base type Code validate(x) Condition Error: ! object is invalid: - Underlying data must be not # validate checks the type of setters Code foo(x = 123) Condition Error: ! @x must be , not S7/tests/testthat/_snaps/generic.md0000644000176200001440000000456214712243611016776 0ustar liggesusers# new_generic checks its inputs Code new_generic(1) Condition Error: ! `name` must be a single string Code new_generic("") Condition Error: ! `name` must not be "" or NA Code new_generic("foo", 1) Condition Error: ! `dispatch_args` must be a character vector Code new_generic("foo", "x", function(x) { }) Condition Error: ! `fun` must contain a call to `S7_dispatch()` # check_dispatch_args() produces informative errors Code check_dispatch_args(1) Condition Error: ! `dispatch_args` must be a character vector Code check_dispatch_args(character()) Condition Error: ! `dispatch_args` must have at least one component Code check_dispatch_args("") Condition Error in `check_dispatch_args()`: ! `dispatch_args` must not be missing or the empty string Code check_dispatch_args(NA_character_) Condition Error in `check_dispatch_args()`: ! `dispatch_args` must not be missing or the empty string Code check_dispatch_args(c("x", "x")) Condition Error: ! `dispatch_args` must be unique Code check_dispatch_args("...") Condition Error: ! Can't dispatch on `...` Code check_dispatch_args("y", function(x, ..., y) { }) Condition Error: ! `dispatch_args` must be a prefix of the generic arguments # S7_generic printing Code foo1 Output foo1(x, ...) with 2 methods: 1: method(foo1, class_character) 2: method(foo1, text) Code foo3 Output foo3(x, y, z, ...) with 3 methods: 1: method(foo3, list(class_character, class_integer, class_character)) 2: method(foo3, list(class_character, class_integer, class_logical)) 3: method(foo3, list(class_character, text, class_character)) # S7_generic printing with long / many arguments Code foo Output foo(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, ...) with 0 methods: # check_generic produces informative errors Code check_generic("x") Condition Error: ! `fun` must be a function Code check_generic(function() { }) Condition Error: ! `fun` must contain a call to `S7_dispatch()` S7/tests/testthat/_snaps/generic-spec.md0000644000176200001440000000047214712423107017722 0ustar liggesusers# can standardise generics Code as_generic(function() { }) Condition Error: ! `generic` is a function, but not an S3 generic function: function () { } --- Code as_generic(1) Condition Error: ! `generic` must be a function, not a S7/tests/testthat/test-valid.R0000644000176200001440000000443614712423107015754 0ustar liggesuserstest_that("validate() validates object and type recursively", { klass <- new_class("klass", package = NULL, properties = list(x = class_double, y = class_double), validator = function(self) { c( if (self@x < 0) "x must be positive", if (self@y > 0) "y must be negative" ) } ) expect_snapshot(error = TRUE, { obj <- klass(1, -1) attr(obj, "x") <- -1 validate(obj) attr(obj, "x") <- "y" validate(obj) }) klass2 <- new_class("klass2", parent = klass, package = NULL, properties = list(z = class_double)) expect_snapshot(error = TRUE, { obj <- klass2(1, -1, 1) attr(obj, "x") <- -1 validate(obj) attr(obj, "x") <- "y" attr(obj, "z") <- "y" validate(obj) }) }) test_that("validate checks base type", { Double <- new_class("Double", package = NULL, parent = class_double) x <- Double(10) mode(x) <- "character" expect_snapshot(error = TRUE, validate(x)) }) test_that("validate checks the type of setters", { foo <- new_class("foo", package = NULL, properties = list(x = new_property( class_double, setter = function(self, value) { self@x <- as.character(value) self } ) )) expect_snapshot(foo(x = 123), error = TRUE) }) test_that("validate does not check type of getters", { # because getters can be peform arbitrary computation and we want # validation to always be cheap prop <- new_property(class_integer, getter = function(self) "x") foo <- new_class("foo", properties = list(x = prop)) expect_no_error(foo()) }) test_that("valid eventually calls the validation function only at the end", { foo <- new_class("foo", properties = list(x = class_double), validator = function(self) if (self@x < 0) "must be positive" ) obj <- foo(10) obj <- valid_eventually(obj, function(self) { self@x <- -1 self@x <- 1 self }) expect_error(validate(obj), NA) }) test_that("valid implicitly does _not_ call the validation function", { foo <- new_class("foo", properties = list(x = class_double), validator = function(self) if (self@x < 0) "must be positive" ) obj <- foo(10) obj <- valid_implicitly(obj, function(self) { self@x <- -1 self }) expect_error(validate(obj), "must be positive") }) S7/tests/testthat/test-base-r.R0000644000176200001440000000255114533115246016025 0ustar liggesusers test_that("base::inherits() accepts S7 objects", { skip_if(getRversion() < "4.3") ClassA <- new_class("ClassA") ClassBA <- new_class("ClassBA", parent = ClassA) ClassX <- new_class("ClassX") expect_no_error(stopifnot(exprs = { isTRUE(inherits(ClassA() , ClassA)) isTRUE(inherits(ClassBA(), ClassA)) isTRUE(inherits(ClassBA(), ClassBA)) isFALSE(inherits(ClassX(), ClassA)) isFALSE(inherits(ClassX(), ClassBA)) })) }) test_that("base::`@` accesses S7 properties", { skip_if(getRversion() < "4.3") range <- new_class( "range", properties = list(start = class_double, end = class_double), validator = function(self) { if (length(self@start) != 1) { "@start must be length 1" } else if (length(self@end) != 1) { "@end must be length 1" } else if (self@end < self@start) { "@end must be greater than or equal to @start" } } ) obj <- range(3, 4) expect_no_error(stopifnot(exprs = { identical(obj@start, 3) identical(obj@end, 4) })) local({ `@` <- base::`@` expect_no_error(stopifnot(exprs = { identical(obj@start, 3) identical(obj@end, 4) })) }) }) test_that("dput() works", { skip_if(getRversion() < "4.4") expect_no_error(dput(new_class("Foo")())) expect_no_error(dput(new_class("Foo"))) }) S7/tests/testthat/test-method-ops.R0000644000176200001440000001040314632312260016721 0ustar liggesuserstest_that("Ops generics dispatch to S7 methods for S7 classes", { local_methods(base_ops[["+"]]) foo1 <- new_class("foo1") foo2 <- new_class("foo2") method(`+`, list(foo1, foo1)) <- function(e1, e2) "foo1-foo1" method(`+`, list(foo1, foo2)) <- function(e1, e2) "foo1-foo2" method(`+`, list(foo2, foo1)) <- function(e1, e2) "foo2-foo1" method(`+`, list(foo2, foo2)) <- function(e1, e2) "foo2-foo2" expect_equal(foo1() + foo1(), "foo1-foo1") expect_equal(foo1() + foo2(), "foo1-foo2") expect_equal(foo2() + foo1(), "foo2-foo1") expect_equal(foo2() + foo2(), "foo2-foo2") expect_error(foo1() + new_class("foo3")(), class = "S7_error_method_not_found") }) test_that("Ops generics dispatch to S3 methods", { skip_if(getRversion() < "4.3") local_methods(base_ops[["+"]]) foo <- new_class("foo") method(`+`, list(class_factor, foo)) <- function(e1, e2) "factor-foo" method(`+`, list(foo, class_factor)) <- function(e1, e2) "foo-factor" expect_equal(foo() + factor(), "foo-factor") expect_equal(factor() + foo(), "factor-foo") # Even if custom method exists foo_S3 <- structure(list(), class = "foo_S3") assign("+.foo_S3", function(e1, e2) stop("Failure!"), envir = globalenv()) defer(rm("+.foo_S3", envir = globalenv())) method(`+`, list(new_S3_class("foo_S3"), foo)) <- function(e1, e2) "S3-S7" method(`+`, list(foo, new_S3_class("foo_S3"))) <- function(e1, e2) "S7-S3" expect_equal(foo() + foo_S3, "S7-S3") expect_equal(foo_S3 + foo(), "S3-S7") }) test_that("Ops generics dispatch to S7 methods for S4 classes", { local_methods(base_ops[["+"]]) fooS4 <- local_S4_class("foo", contains = "character") fooS7 <- new_class("foo") method(`+`, list(fooS7, fooS4)) <- function(e1, e2) "S7-S4" method(`+`, list(fooS4, fooS7)) <- function(e1, e2) "S4-S7" expect_equal(fooS4() + fooS7(), "S4-S7") expect_equal(fooS7() + fooS4(), "S7-S4") }) test_that("Ops generics dispatch to S7 methods for POSIXct", { # In R's C sources DispatchGroup() has special cases for POSIXt/Date/difftime # so we need to double check that S7 methods still take precedence: # https://github.com/wch/r-source/blob/5cc4e46fc/src/main/eval.c#L4242C1-L4247C64 skip_if(getRversion() < "4.3") local_methods(base_ops[["+"]]) foo <- new_class("foo") method(`+`, list(foo, class_POSIXct)) <- function(e1, e2) "foo-POSIXct" expect_equal(foo() + Sys.time(), "foo-POSIXct") method(`+`, list(class_POSIXct, foo)) <- function(e1, e2) "POSIXct-foo" expect_equal(Sys.time() + foo(), "POSIXct-foo") }) test_that("Ops generics dispatch to S7 methods for NULL", { local_methods(base_ops[["+"]]) foo <- new_class("foo") method(`+`, list(foo, NULL)) <- function(e1, e2) "foo-NULL" method(`+`, list(NULL, foo)) <- function(e1, e2) "NULL-foo" expect_equal(foo() + NULL, "foo-NULL") expect_equal(NULL + foo(), "NULL-foo") }) test_that("Ops generics falls back to base behaviour", { local_methods(base_ops[["+"]]) foo <- new_class("foo", parent = class_double) expect_equal(foo(1) + 1, foo(2)) expect_equal(foo(1) + 1:2, 2:3) expect_equal(1 + foo(1), foo(2)) expect_equal(1:2 + foo(1), 2:3) # but can be overridden method(`+`, list(foo, class_numeric)) <- function(e1, e2) "foo-numeric" method(`+`, list(class_numeric, foo)) <- function(e1, e2) "numeric-foo" expect_equal(foo(1) + 1, "foo-numeric") expect_equal(foo(1) + 1:2, "foo-numeric") expect_equal(1 + foo(1), "numeric-foo") expect_equal(1:2 + foo(1), "numeric-foo") }) test_that("`%*%` dispatches to S7 methods", { skip_if(getRversion() < "4.3") local_methods(base_ops[["+"]]) ClassX <- new_class("ClassX") method(`%*%`, list(ClassX, class_any)) <- function(x, y) "ClassX %*% class_any" method(`%*%`, list(class_any, ClassX)) <- function(x, y) "class_any %*% ClassX" expect_equal(ClassX() %*% ClassX(), "ClassX %*% class_any") expect_equal(ClassX() %*% 1, "ClassX %*% class_any") expect_equal(1 %*% ClassX(), "class_any %*% ClassX") }) test_that("Ops methods can use super", { foo <- new_class("foo", class_integer) foo2 <- new_class("foo2", foo) method(`+`, list(foo, class_double)) <- function(e1, e2) { foo(S7_data(e1) + as.integer(e2)) } method(`+`, list(foo2, class_double)) <- function(e1, e2) { foo2(super(e1, foo) + e2) } expect_equal(foo2(1L) + 1, foo2(2L)) }) S7/tests/testthat/test-convert.R0000644000176200001440000000622714712423107016335 0ustar liggesuserstest_that("can register convert methods", { local_methods(convert) converttest <- new_class("converttest", package = NULL) method(convert, list(converttest, class_character)) <- function(from, to, ...) "c" method(convert, list(converttest, class_integer)) <- function(from, to, ...) "i" obj <- converttest() expect_equal(convert(obj, to = class_character), "c") expect_equal(convert(obj, to = class_integer), "i") # Errors if none found expect_snapshot(convert(obj, to = class_double), error = TRUE) }) test_that("doesn't convert to subclass", { local_methods(convert) converttest1 <- new_class("converttest1") converttest2 <- new_class("converttest2", converttest1) method(convert, list(class_integer, converttest1)) <- function(from, to, ...) "i" expect_error(convert(class_integer, to = converttest2), "Can't find method") }) describe("fallback convert", { local_methods(convert) it("can convert to own class", { foo1 <- new_class("foo1", package = NULL) foo2 <- new_class("foo2", foo1, package = NULL) obj <- convert(foo2(), to = foo2) expect_equal(class(obj), c("foo2", "foo1", "S7_object")) expect_equal(S7_class(obj), foo2) }) it("can convert to super class", { foo1 <- new_class("foo1", properties = list(x = class_double), package = NULL) foo2 <- new_class("foo2", foo1, properties = list(y = class_double), package = NULL) obj <- convert(foo2(1, 2), to = foo1) expect_equal(class(obj), c("foo1", "S7_object")) expect_equal(S7_class(obj), foo1) expect_equal(props(obj), list(x = 1)) expect_equal(attr(obj, "y"), NULL) }) it("can convert to subclass", { Foo <- new_class("Foo", properties = list(x = class_numeric)) Bar <- new_class("Bar", Foo, properties = list(y = class_numeric)) foo <- Foo(x = 1) # Basic conversion bar <- convert(foo, Bar) expect_s3_class(bar, c("Bar", "Foo", "S7_object")) expect_equal(S7_class(bar), Bar) expect_equal(bar@x, 1) expect_equal(bar@y, numeric(0)) # Overriding existing property bar <- convert(foo, Bar, x = 2) expect_equal(bar@x, 2) # Setting new property bar <- convert(foo, Bar, y = 2) expect_equal(bar@x, 1) expect_equal(bar@y, 2) # Setting both properties bar <- convert(foo, Bar, y = 2, x = 3) expect_equal(bar@x, 3) expect_equal(bar@y, 2) # Error on converting to unrelated class Unrelated <- new_class("Unrelated", properties = list(z = class_character)) expect_error(convert(foo, Unrelated), "Can't find method") }) it("can convert to S3 class", { factor2 <- new_class("factor2", class_factor, properties = list(x = class_double)) obj <- convert(factor2(1, "x", x = 1), to = class_factor) expect_equal(class(obj), "factor") expect_equal(S7_class(obj), NULL) expect_equal(attr(obj, "x"), NULL) }) it("can convert to base type", { character2 <- new_class("character2", parent = class_character, properties = list(x = class_double) ) obj <- convert(character2("x", x = 1), to = class_character) expect_equal(attr(obj, "class"), NULL) expect_equal(S7_class(obj), NULL) expect_equal(attr(obj, "x"), NULL) }) }) S7/tests/testthat/test-base.R0000644000176200001440000002072514712243624015572 0ustar liggesuserstest_that("validation uses typeof", { expect_equal(class_integer$validator(1L), NULL) expect_equal(class_integer$validator(factor()), NULL) expect_snapshot(class_integer$validator(TRUE)) expect_equal(class_function$validator(`[`), NULL) expect_equal(class_function$validator(sum), NULL) expect_equal(class_function$validator(mean), NULL) }) test_that("base class display as expected", { expect_snapshot({ class_integer str(class_integer) }) }) test_that("classes can inherit from base types", { base_classes <- c(class_vector$classes, list(class_function)) for (class in base_classes) { foo <- new_class("foo", parent = class) expect_error(foo(), NA) } }) test_that("Base classes can be a parent class", { expect_no_error({ Foo := new_class(class_logical) Foo() Foo(TRUE) }) expect_error(Foo(1), "must be not ") expect_no_error({ Foo := new_class(class_integer) Foo() Foo(1L) }) expect_error(Foo(1), "must be not ") expect_no_error({ Foo := new_class(class_double) Foo() Foo(1) }) expect_error(Foo(1L), "must be not ") expect_no_error({ Foo := new_class(class_complex) Foo() Foo(1 + 1i) }) expect_error(Foo(1), "must be not ") expect_no_error({ Foo := new_class(class_character) Foo() Foo("a") }) expect_error(Foo(1), "must be not ") expect_no_error({ Foo := new_class(class_raw) Foo() Foo(charToRaw("a")) }) expect_error(Foo(1), "must be not ") expect_no_error({ Foo := new_class(class_list) Foo() Foo(list()) }) expect_error(Foo(1), "must be not ") expect_no_error({ Foo := new_class(class_expression) Foo() Foo(expression(1)) }) expect_error(Foo(1), "must be not ") expect_no_error({ Foo := new_class(class_call) Foo() Foo(quote(a())) }) expect_error(Foo(1), "must be not ") expect_no_error({ Foo := new_class(class_function) Foo() Foo(identity) }) expect_error(Foo(1), "must be not ") # union types cannot be a parent: # # class_numeric # class_atomic # class_vector # class_language # class_name cannot be a parent because: # 'Error: cannot set attribute on a symbol' # class_environment cannot currently be a parent # (this is expected to change in the future) }) test_that("All base classes can be a property class", { expect_no_error({ Foo := new_class(properties = list(x = class_logical)) Foo(x = TRUE) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_integer)) Foo(x = 1L) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_double)) Foo(x = 1) }) expect_error(Foo(x = 1L), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_complex)) Foo(x = 1 + 1i) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_character)) Foo(x = "a") }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_raw)) Foo(x = charToRaw("a")) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_list)) Foo(x = list()) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_expression)) Foo(x = expression(1)) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_call)) Foo(x = quote(a())) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_function)) Foo(x = identity) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_name)) Foo(x = quote(a)) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_environment)) Foo(x = new.env()) }) expect_error(Foo(x = 1), "@x must be , not ") expect_no_error({ Foo := new_class(properties = list(x = class_atomic)) Foo(x = 1) }) expect_error(Foo(x = list(TRUE)), "@x must be .*, not ") expect_no_error({ Foo := new_class(properties = list(x = class_vector)) Foo(x = 1) }) expect_error(Foo(x = quote(x)), "@x must be .*, not ") expect_no_error({ Foo := new_class(properties = list(x = class_language)) Foo(x = quote(a())) }) expect_error(Foo(x = 1), "@x must be .*, not ") expect_no_error({ Foo := new_class(properties = list(x = class_numeric)) Foo(x = 1) }) expect_error(Foo(x = TRUE), "@x must be .*, not ") }) test_that("Base S3 classes can be parents", { expect_no_error({ Foo := new_class(class_factor) Foo() Foo(1L, levels = letters[1:3]) Foo(factor(letters[1:3])) }) expect_no_error({ Foo := new_class(class_Date) Foo() Foo(Sys.Date()) Foo(rep(Sys.Date(), 3)) Foo(1) }) expect_error(Foo("a"), "Underlying data must be numeric") expect_no_error({ Foo := new_class(class_POSIXct) Foo() Foo(Sys.time()) Foo(rep(Sys.time(), 3)) Foo(1) }) expect_error(Foo("a"), "Underlying data must be numeric") expect_no_error({ Foo := new_class(class_data.frame) Foo() Foo(data.frame(x = 1)) Foo(list(x = 1)) Foo(list(x = 1), "rowname") }) expect_error(Foo(list(x = 1:3, y = 1:4)), "all variables should have the same length") # expect_no_error({ # Foo := new_class(class_matrix) # Foo(1:4, nrow = 2) # Foo(NA) # Foo(matrix(1:4, nrow = 2)) # }) # expect_no_error({ # Foo := new_class(class_array) # # Foo(array(1:4, dim = c(2, 2))) # Foo(1:4, dim = c(2, 2)) # # Foo(array(1:24, dim = c(2, 3, 4))) # Foo(1:24, dim = c(2, 3, 4)) # # Foo(array(1)) # Foo(1) # }) expect_no_error({ Foo := new_class(class_formula) Foo(~ x) Foo("~ x") Foo(call("~", 1, 2)) Foo(quote(~x)) }) }) test_that("Base S3 classes can be properties", { expect_no_error({ Foo := new_class(properties = list(x = class_factor)) Foo(x = factor()) }) expect_error(Foo(x = 1), "@x must be S3, not ") expect_no_error({ Foo := new_class(properties = list(x = class_data.frame)) Foo(x = data.frame()) }) expect_error(Foo(x = 1), "@x must be S3, not ") # expect_no_error({ # Foo := new_class(properties = list(x = class_matrix)) # Foo(x = matrix()) # }) # expect_error(Foo(x = 1), "@x must be S3, not ") # expect_no_error({ # Foo := new_class(properties = list(x = class_array)) # Foo(x = array()) # }) # expect_error(Foo(x = 1), "@x must be S3, not ") expect_no_error({ Foo := new_class(properties = list(x = class_formula)) Foo(x = ~ x) }) expect_error(Foo(x = 1), "@x must be S3, not ") expect_no_error({ Foo := new_class(properties = list(x = class_Date)) Foo(x = Sys.Date()) }) expect_error(Foo(x = 1), "@x must be S3, not ") expect_no_error({ Foo := new_class(properties = list(x = class_POSIXct)) Foo(x = Sys.time()) }) expect_error(Foo(x = 1), "@x must be S3, not ") expect_no_error({ Foo := new_class(properties = list(x = class_POSIXlt)) Foo(x = as.POSIXlt(Sys.time())) }) expect_error(Foo(x = 1), "@x must be S3, not ") expect_no_error({ Foo := new_class(properties = list(x = class_POSIXt)) Foo(x = Sys.time()) Foo(x = as.POSIXlt(Sys.time())) }) expect_error(Foo(x = 1), "@x must be S3, not ") }) test_that("inherits() works with S7_base_class", { # nameOfClass() introduced in R 4.3 skip_if(getRversion() < "4.3") # test nameOfClass.S7_base_class expect_true(inherits("foo", class_character)) Foo := new_class(class_character) expect_true(inherits(Foo(), "character")) expect_true(inherits(Foo(), class_character)) }) S7/tests/testthat/test-method-dispatch.R0000644000176200001440000001473714712423107017737 0ustar liggesusersdescribe("single dispatch", { foo <- new_generic("foo", "x") it("works for specials", { method(foo, class_any) <- function(x) "fallback" expect_equal(foo(), "fallback") expect_equal(foo(1), "fallback") method(foo, class_missing) <- function(x) "missing" expect_equal(foo(), "missing") }) it("works for base types", { method(foo, class_character) <- function(x) "base" expect_equal(foo("bar"), "base") }) it("works for S7 objects", { text <- new_class("text", class_character) method(foo, text) <- function(x) "S7" expect_equal(foo(text("bar")), "S7") }) it("works for S3 objects", { obj <- structure("hi", class = "my_S3") method(foo, new_S3_class("my_S3")) <- function(x) "S3" expect_equal(foo(obj), "S3") }) it("works for S4 objects", { my_S4 <- setClass("my_S4", contains = "numeric") method(foo, my_S4) <- function(x) "S4" expect_equal(foo(my_S4(1)), "S4") }) it("works for unions", { method(foo, new_union(class_integer, class_logical)) <- function(x) "union" expect_equal(foo(TRUE), "union") expect_equal(foo(1L), "union") }) }) describe("multiple dispatch", { it("works", { foo1 <- new_class("foo1") foo2 <- new_class("foo2", foo1) bar <- new_generic("bar", c("x", "y")) method(bar, list(foo1, foo1)) <- function(x, y) c(1, 1) method(bar, list(foo2, foo2)) <- function(x, y) c(2, 2) expect_equal(bar(foo1(), foo1()), c(1, 1)) expect_equal(bar(foo1(), foo2()), c(1, 1)) expect_equal(bar(foo2(), foo1()), c(1, 1)) expect_equal(bar(foo2(), foo2()), c(2, 2)) }) }) test_that("can substitute() args", { foo <- new_generic("foo", "x", function(x, ..., z = 1) S7_dispatch()) method(foo, class_character) <- function(x, ..., z = 1) substitute(x) expect_equal(foo(letters), quote(letters)) suppressMessages( method(foo, class_character) <- function(x, ..., z = 1, y) substitute(y) ) expect_equal(foo("x", y = letters), quote(letters)) suppressMessages( method(foo, class_character) <- function(x, ..., z = 1) substitute(z) ) expect_equal(foo("x", z = letters), quote(letters)) suppressMessages( method(foo, class_character) <- function(x, ..., z = 1) substitute(list(...)) ) expect_equal(foo("x", abc = xyz), quote(list(abc = xyz))) suppressMessages( method(foo, class_character) <- function(x, ..., z = 1, y) missing(y) ) expect_true(foo("x"), TRUE) expect_true(foo("x", y =), TRUE) expect_true(foo("x", y =), TRUE) suppressMessages( method(foo, class_character) <- function(x, ..., z = 1, y) ...length() ) expect_equal(foo("x"), 0) expect_equal(foo("x", y =), 0) expect_equal(foo("x", y =, abc), 1) expect_equal(foo("x", y =, abc = xyz), 1) expect_equal(foo("x", y =, abc, xyz), 2) }) test_that("methods get values modified in the generic", { foo <- new_generic("foo", "x", function(x, y = 1) { y <- 10 S7_dispatch() }) method(foo, class_character) <- function(x, y = 1) y expect_equal(foo("x", 1), 10) }) test_that("dispatched arguments are evaluated once", { counter <- local({ i <- 0 function() { i <<- i + 1 i } }) f <- new_generic("f", "x") method(f, class_double) <- function(x) x expect_equal(f(counter()), 1) }) test_that("generics pass ... to methods", { foo <- new_generic("foo", "x") method(foo, class_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", { foo <- new_generic("foo", "x", function(x, ..., z = 1) S7_dispatch()) method(foo, class_character) <- function(x, ..., z = 1) z expect_equal(foo("x", z = 3), 3) }) test_that("can dispatch on base 'union' types", { foo <- new_generic("foo", "x") suppressMessages({ method(foo, class_vector) <- function(x) "v" method(foo, class_atomic) <- function(x) "a" method(foo, class_numeric) <- function(x) "n" method(foo, class_integer) <- function(x) "i" }) expect_equal(foo(list()), "v") expect_equal(foo(character()), "a") expect_equal(foo(double()), "n") expect_equal(foo(integer()), "i") }) test_that("single dispatch fails with informative messages", { fail <- new_generic("fail", "x") foo <- new_class("foo", package = NULL) Foo <- setClass("Foo", slots = list("x" = "numeric")) on.exit(S4_remove_classes("Foo")) expect_snapshot(error = TRUE, { fail(TRUE) fail(tibble::tibble()) fail(foo()) fail(Foo(x = 1)) }) expect_error(fail(TRUE), class = "S7_error_method_not_found") }) test_that("multiple dispatch fails with informative messages", { fail <- new_generic("fail", c("x", "y")) foo <- new_class("foo") Foo <- setClass("Foo", slots = list("x" = "numeric")) on.exit(S4_remove_classes("Foo")) expect_snapshot(error = TRUE, { fail(TRUE) fail(, TRUE) fail(TRUE, TRUE) }) expect_error(fail(TRUE, TRUE), class = "S7_error_method_not_found") }) test_that("method dispatch preserves method return visibility", { foo <- new_generic("foo", "x") method(foo, class_integer) <- function(x) invisible("bar") expect_invisible(foo(1L)) method(foo, class_character) <- function(x) { if (x == "nope") return(invisible("bar")) "bar" } expect_visible(foo("yep")) expect_invisible(foo("nope")) }) test_that("can dispatch on evaluated arguments", { my_generic <- new_generic("my_generic", "x", function(x) { x <- 10 S7_dispatch() }) method(my_generic, class_numeric) <- function(x) 100 expect_equal(my_generic("x"), 100) }) test_that("method dispatch works for class_missing", { foo <- new_generic("foo", "x") method(foo, class_missing) <- function(x) missing(x) expect_true(foo()) # dispatch on class_missing only works directly in the generic call foo_wrapper <- function(xx) foo(xx) expect_snapshot( error = TRUE, variant = if (getRversion() < "4.3") "R-lt-4-3", foo_wrapper() ) }) test_that("errors from dispatched methods have reasonable tracebacks", { get_call_stack <- function(n = 3) { x <- sys.calls() x <- x[-length(x)] # remove get_call_stack() x <- tail(x, n) lapply(x, utils::removeSource) } my_generic <- new_generic("my_generic", "x") method(my_generic, class_numeric) <- function(x) get_call_stack() expect_snapshot(my_generic(10)) my_generic <- new_generic("my_generic", c("x", "y")) method(my_generic, list(class_numeric, class_numeric)) <- function(x, y) get_call_stack() expect_snapshot(my_generic(3, 4)) }) S7/tests/testthat/test-inherits.R0000644000176200001440000000122414712423107016472 0ustar liggesuserstest_that("it works", { foo1 <- new_class("foo1") foo2 <- new_class("foo2", parent = foo1) expect_true(S7_inherits(foo1(), NULL)) expect_true(S7_inherits(foo1(), foo1)) expect_true(S7_inherits(foo2(), foo1)) expect_false(S7_inherits(foo1(), foo2)) expect_false(S7_inherits(1, NULL)) }) test_that("checks that input is a class", { expect_snapshot(S7_inherits(1:10, "x"), error = TRUE) }) test_that("throws informative error", { expect_snapshot(error = TRUE, { foo1 <- new_class("foo1", package = NULL) foo2 <- new_class("foo2", package = NULL) check_is_S7(foo1(), foo2) }) expect_snapshot(check_is_S7("a"), error = TRUE) }) S7/tests/testthat.R0000644000176200001440000000006014415063017013665 0ustar liggesuserslibrary(testthat) library(S7) test_check("S7") S7/MD50000644000176200001440000002117514713133572011067 0ustar liggesusers98c77f7e53e64370cb35fa0480e976ff *DESCRIPTION 55a910047be2c2d8749573ab45ad345f *LICENSE f0f73e043f0370460e786e36b513fd6a *NAMESPACE 37e695308d02d7e548d1f2f822f79d2c *NEWS.md ef802d0beba177b3184e86104e925adb *R/S3.R 72f587df6ab10e975cd7a4752ef1f3aa *R/S4.R 98620643b51986b34782c07daaf6a18c *R/S7-package.R b0fbb7a0a41026e212e1bf67d0228ce3 *R/aaa.R c551c68bf84fe6f7dc0a50749b9f4b8f *R/base.R 728e4d1e1f8f2d323a1bca0cfa43c6c8 *R/class-spec.R 2e4db69c29f7c8a8d681f6ece4753dd0 *R/class.R eb2083f7166ffe256e1d4eee2c0d6f08 *R/compatibility.R d002e97bab69dae7607f3b09d7fbc82f *R/constructor.R ea5512be7bff22fc75b37cfcbb394229 *R/convert.R 675cd7ec799ea913bb2a93a1bc67936e *R/data.R 3d8b96137e4fa1b21930186f2a6ab106 *R/external-generic.R 689f2dc2182eaf4327831f9dab62eed3 *R/generic-spec.R 744c32b2a4a819337de2aad1f018aa89 *R/generic.R 7a83ea11fd3d5cac1ce12cceee452072 *R/inherits.R fef856df215ff0270c208bc8439aa7fb *R/method-dispatch.R ecf4df6d9d43c0d46856737a1f287e40 *R/method-introspect.R c4c0a56712d763f543ce1a0e5f4d0661 *R/method-ops.R b6e8b166d63358d8d061bb36b2a426fe *R/method-register.R 7c5a318d2aa5428a522993a25d3ae7a5 *R/property.R 15e069f62344c3e813fa169f79596ec3 *R/special.R a87c5f58f569fd7353ae53441b11c98f *R/super.R a45094e96500eefe527c2e3d8b826afc *R/union.R c08d4955e0da6c45201df9efe809b4cf *R/utils.R e23485a8b1727b8007d1ae1966b223d8 *R/valid.R 029443cd5d7428c0fb17957f2f554ed5 *R/zzz.R 4aea487376d52d34575d760f9408979d *README.md 6ac5d8db77bfc789d72c337147688fbd *build/vignette.rds 6a873554b3910148bcf9ab449c96803e *inst/doc/S7.R 98957e1a93532cb146eeea40b34dce4e *inst/doc/S7.Rmd 1add4c1bc2b5acd8307c694ed39e99e5 *inst/doc/S7.html 4a9f5fa65dc17c39757f066840999155 *inst/doc/classes-objects.R 3df4d837b2c8abe8fdf13ea01d18ef49 *inst/doc/classes-objects.Rmd 269c0033a25a44dfbfe9cfe774b8c8a3 *inst/doc/classes-objects.html 1a004971b5e4a548df42fd58480511e2 *inst/doc/compatibility.R 3f0277e99b89e2ba6b75fb0de9ba6909 *inst/doc/compatibility.Rmd 1fb97e553818e710b520e6810a8e16c4 *inst/doc/compatibility.html e92d275cb357093abec6ed457688950c *inst/doc/generics-methods.R 63fe07b268ff19f1ed6db87d92039c54 *inst/doc/generics-methods.Rmd 0c51ddc888a643bda30399cbf58a407e *inst/doc/generics-methods.html ed472ce2aa8de172529397bd4a67c3f7 *inst/doc/motivation.R 9671c6c6d7e9b089a7fdf5d6d38de59c *inst/doc/motivation.Rmd 3c14ad41a48a803fef96573d788b515a *inst/doc/motivation.html 2122e77df412ebb98388321b1883c172 *inst/doc/packages.R f24eb7eb45b0ded0aaa59797ccacad08 *inst/doc/packages.Rmd 9331a8718ede5f239f6cf72a82a09556 *inst/doc/packages.html 1c661c9b61fbf6a39384ee67bbd3ec06 *inst/doc/performance.R a81efab9e80a24528974c3c9c2f217ba *inst/doc/performance.Rmd c83e3c7ac17ed946c0684a7b617f0b58 *inst/doc/performance.html 7fb93a798fdbf297a6906afa537e7e66 *man/S4_register.Rd 385334664274daee4c607818da58b76b *man/S7_class.Rd d5477f22e0450196786a933c69b1857e *man/S7_data.Rd 6d1d2c239c3613aea6e157f1e11e2248 *man/S7_inherits.Rd 046e7c42c46fd0a401719ac72b2bba55 *man/S7_object.Rd 3087c32d3c89b9f20695ab886e435b0a *man/as_class.Rd 9021bb70b139883805fb4d39d341e191 *man/base_classes.Rd 26f0610a0b5220707d300ce069961752 *man/base_s3_classes.Rd b0b8ed2f0eed53c5811152035dcda2be *man/class_any.Rd 2dcef520f2e116f4a8c85a7720b08412 *man/class_missing.Rd dd2a6227c95d7809b3af707bf902ec7d *man/convert.Rd aa58837fc507680178c87d0947bc6070 *man/method-set.Rd 4229a7db12aff9a10ac492286f8d36c7 *man/method.Rd a4f570151fa7f2dd435ec83aa48ea1dd *man/method_explain.Rd f2f16e7518c965a7ac5917e5733df069 *man/methods_register.Rd 228a4f2c365d201e1550f811dfdabc88 *man/new_S3_class.Rd 9cdf5a00fdcff7fd6891ab48a873f1c1 *man/new_class.Rd 29a33bdf8cd0349dcac575e41b0091eb *man/new_external_generic.Rd 11c6643afce4bf58da76a5a8da24afce *man/new_generic.Rd 01f32ad1986408c73117f99194e7970b *man/new_property.Rd 8d12acc366b918c521b0e0aa840021b3 *man/new_union.Rd cb631b8d6aff13551185b48d4622f329 *man/prop.Rd 47908e6db5b40616ecb7910699d4ac53 *man/prop_names.Rd 3ff3af6a71d127380b940404c5b6c698 *man/props.Rd bf50095083464b5764ee587978abb1f7 *man/super.Rd 57d04960d6366fafa3a6f960a4fd6acb *man/validate.Rd 4d0cf4413b51db401efca9a74c314b25 *src/init.c 05cefac1be4938ef745badcd70b074e4 *src/method-dispatch.c fc51def03222ee4aad4a654c38c8c034 *src/prop.c fb21f5c62831e1ecf722f9dc1868c195 *tests/testthat.R b4ddf0243721d47a5d7ec3faabdaa1e7 *tests/testthat/_snaps/R-lt-4-3/method-dispatch.md 054c9bf688cd245ecf3ad020c066da07 *tests/testthat/_snaps/S3.md bca887779688c5b262cbeb477e095cf0 *tests/testthat/_snaps/S4.md 01a1d8be85a9904d8a08ee7aee4b8241 *tests/testthat/_snaps/base.md 4c289016f295e3dcd48a0e8749a7e29c *tests/testthat/_snaps/class-spec.md 40a19a3c15ccabe7580730bcaf79ddb5 *tests/testthat/_snaps/class.md 0a673d5fb21d8316d1030a72d744d3fa *tests/testthat/_snaps/constructor.md c508ea5f1db713cc2e169bf1cfbf732c *tests/testthat/_snaps/convert.md 7d05a5c8e1d73579bb181b6fec08b315 *tests/testthat/_snaps/external-generic.md b3d24ed9b2674ac45b31b350a2597405 *tests/testthat/_snaps/generic-spec.md 3bca949d18504758c784fa5336a1fd43 *tests/testthat/_snaps/generic.md 9ae7aa8a4255987fbcff2b7ed4e6e680 *tests/testthat/_snaps/inherits.md 6b9dc8a6e5caef7a567408f4c114237a *tests/testthat/_snaps/method-dispatch.md d57041cc006824cbc63a1763d26648f1 *tests/testthat/_snaps/method-introspect.md 8a9aafc6e7be43783f81b34e41c9aec8 *tests/testthat/_snaps/method-register.md 2b6b8226c13a33bae5f7c938b5b481e4 *tests/testthat/_snaps/property.md 29b14728c013b7cbfadc704ffd3a6838 *tests/testthat/_snaps/special.md 0d09f924ff97c56148cfc3c84565d579 *tests/testthat/_snaps/super.md 6cc6455d4a56826eae71c73accb32a2f *tests/testthat/_snaps/union.md 45eead311b1690fa9128a054b3f09541 *tests/testthat/_snaps/valid.md 4dac50eb1bc138e7e96267f7a99edccf *tests/testthat/_snaps/zzz.md 682ee9f57ec8c9f8a627866489f9e611 *tests/testthat/helper.R c9d9bec68bfbc3f3116602f54073a182 *tests/testthat/t0/DESCRIPTION 585d7016e43748abd8b0ab4a0d343f85 *tests/testthat/t0/NAMESPACE eaef5585ee41da75a8fda5ac889844f1 *tests/testthat/t0/R/t0.R 5d1c79a0ad2fc03b2eb7ddfdaf6a6864 *tests/testthat/t1/DESCRIPTION cd158e2d1c48e9aa1753e0daad7a0124 *tests/testthat/t1/NAMESPACE bff384abe65a3a00a2b7cfd087738df5 *tests/testthat/t1/R/t1.R 5184bbabe623b87ee89c66a1bdf18717 *tests/testthat/t2/DESCRIPTION 6329bb3bfe52af428a8fb04cba612aa2 *tests/testthat/t2/NAMESPACE 48ad2d4c31585e74fec21952f8356f61 *tests/testthat/t2/R/t2.R ce3974120f0a1ebd53b1d1e43f42af29 *tests/testthat/test-S3.R f5dd065c9198c474e766047719242628 *tests/testthat/test-S4.R 1f6077c16e11451e169ce49d3ed84536 *tests/testthat/test-base-r.R c641dfd97a87f19195ab6dab7661196e *tests/testthat/test-base.R 8d3be5500c8215aa684cb0c1d4137c25 *tests/testthat/test-class-spec.R 463c2cb6260b53845f9bbfd82a063bd0 *tests/testthat/test-class.R 637cf253a1c2ca9aa6a550e18259bd87 *tests/testthat/test-constructor.R 03a054e0012d32dac7d1d090bbc4701a *tests/testthat/test-convert.R 77d1515c740c4735480455dd434dd28f *tests/testthat/test-data.R 7aa01b56a8fc0504d14860bfe921361a *tests/testthat/test-external-generic.R 7e8bee1a9e150adcf8f19135baf5e356 *tests/testthat/test-generic-spec.R 322e216db5ea97f55f33c90f95e3ea3c *tests/testthat/test-generic.R b4074bb196307f36ab23f2dc7a8b3004 *tests/testthat/test-inherits.R b3600aa0cf01e2523cf246e6cc6dce63 *tests/testthat/test-method-dispatch.R 5822c53b90c1fd1fa41e5a327da24c47 *tests/testthat/test-method-introspect.R 87b4b223756d32e182a61222a730f467 *tests/testthat/test-method-ops.R a45ca74159f8f4cea5622aef8c263fa0 *tests/testthat/test-method-register.R 80d8218031089a74a330e013c74306d2 *tests/testthat/test-property.R 61a844e15ccfa251e39758a1356d7362 *tests/testthat/test-special.R 4d8c70f11151843e27c5737bb2373786 *tests/testthat/test-super.R 8a4dfe4aa8d0d4338f992c7b58c0db79 *tests/testthat/test-union.R 2d91d010ee49052d3fec98da98225361 *tests/testthat/test-valid.R c60fef71bc67f02ffd09abfc2b9508d6 *tests/testthat/test-zzz.R 98957e1a93532cb146eeea40b34dce4e *vignettes/S7.Rmd 3df4d837b2c8abe8fdf13ea01d18ef49 *vignettes/classes-objects.Rmd 3f0277e99b89e2ba6b75fb0de9ba6909 *vignettes/compatibility.Rmd 63fe07b268ff19f1ed6db87d92039c54 *vignettes/generics-methods.Rmd 96b030e6c6082c0d09dd00bf5e35a162 *vignettes/minutes/2021-05-18.Rmd e87e1e55e9fb1d381469915e42069f5b *vignettes/minutes/2022-02-12.Rmd 71b87da944edf100b09a7d60f085ed3e *vignettes/minutes/2022-03-08.Rmd c2844f426c4fd0df534d277387de4ce5 *vignettes/minutes/2022-08-01.Rmd c066fbbe7ce778203aba95d0b9f17a52 *vignettes/minutes/2022-09-12.Rmd 9671c6c6d7e9b089a7fdf5d6d38de59c *vignettes/motivation.Rmd f24eb7eb45b0ded0aaa59797ccacad08 *vignettes/packages.Rmd a81efab9e80a24528974c3c9c2f217ba *vignettes/performance.Rmd f793101ce4f3406cc20ac702327ad41e *vignettes/spec/design.Rmd ea74da813c4ab432ff693cc63049dcc5 *vignettes/spec/dispatch.Rmd 9deb578614162e1ea6b2e4bd8dc9f2ea *vignettes/spec/proposal.Rmd e44367fd2456665361a30198a116a198 *vignettes/spec/requirements.Rmd S7/R/0000755000176200001440000000000014712702212010742 5ustar liggesusersS7/R/S3.R0000644000176200001440000002562014712423107011362 0ustar liggesusers#' Declare an S3 class #' #' To use an S3 class with S7, you must explicitly declare it using #' `new_S3_class()` because S3 lacks a formal class definition. #' (Unless it's an important base class already defined in [base_s3_classes].) #' #' # Method dispatch, properties, and unions #' There are three ways of using S3 with S7 that only require the S3 class #' vector: #' #' * Registering a S3 method for an S7 generic. #' * Restricting an S7 property to an S3 class. #' * Using an S3 class in an S7 union. #' #' This is easy, and you can usually include the `new_S3_class()` #' call inline: #' #' ```R #' method(my_generic, new_S3_class("factor")) <- function(x) "A factor" #' new_class("MyClass", properties = list(types = new_S3_class("factor"))) #' new_union("character", new_S3_class("factor")) #' ``` #' #' # Extending an S3 class #' #' Creating an S7 class that extends an S3 class requires more work. You'll #' also need to provide a constructor for the S3 class that follows S7 #' conventions. This means the first argument to the constructor should be #' `.data`, and it should be followed by one argument for each attribute used #' by the class. #' #' This can be awkward because base S3 classes are usually heavily wrapped for user #' convenience and no low level constructor is available. For example, the #' factor class is an integer vector with a character vector of `levels`, but #' there's no base R function that takes an integer vector of values and #' character vector of levels, verifies that they are consistent, then #' creates a factor object. #' #' You may optionally want to also provide a `validator` function which will #' ensure that [validate()] confirms the validity of any S7 classes that build #' on this class. Unlike an S7 validator, you are responsible for validating #' the types of the attributes. #' #' The following code shows how you might wrap the base Date class. #' A Date is a numeric vector with class `Date` that can be constructed with #' `.Date()`. #' #' ```R #' S3_Date <- new_S3_class("Date", #' function(.data = integer()) { #' .Date(.data) #' }, #' function(self) { #' if (!is.numeric(self)) { #' "Underlying data must be numeric" #' } #' } #' ) #' ``` #' #' @export #' @param class S3 class vector (i.e. what `class()` returns). For method #' registration, you can abbreviate this to a single string, the S3 class #' name. #' @param constructor An optional constructor that can be used to create #' objects of the specified class. This is only needed if you wish to #' have an S7 class inherit from an S3 class or to use the S3 class as a #' property without a default. It must be specified in the #' same way as a S7 constructor: the first argument should be `.data` #' (the base type whose attributes will be modified). #' #' All arguments to the constructor should have default values so that #' when the constructor is called with no arguments, it returns returns #' an "empty", but valid, object. #' @param validator An optional validator used by [validate()] to check that #' the S7 object adheres to the constraints of the S3 class. #' #' A validator is a single argument function that takes the object to #' validate and returns `NULL` if the object is valid. If the object is #' invalid, it returns a character vector of problems. #' @returns An S7 definition of an S3 class, i.e. a list with class #' `S7_S3_class`. #' @examples #' # No checking, just used for dispatch #' Date <- new_S3_class("Date") #' #' my_generic <- new_generic("my_generic", "x") #' method(my_generic, Date) <- function(x) "This is a date" #' #' my_generic(Sys.Date()) new_S3_class <- function(class, constructor = NULL, validator = NULL) { if (!is.character(class)) { stop("`class` must be a character vector", call. = FALSE) } if (!is.null(constructor)) { check_S3_constructor(constructor) } else { constructor <- function(.data) { stop(sprintf("S3 class <%s> doesn't have a constructor", class[[1]]), call. = FALSE) } } out <- list( class = class, constructor = constructor, validator = validator ) class(out) <- "S7_S3_class" out } #' @export print.S7_S3_class <- function(x, ...) { cat(": ", class_desc(x), "\n", sep = "") invisible(x) } #' @export str.S7_S3_class <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") print(object, ..., nest.lev = nest.lev) } check_S3_constructor <- function(constructor) { arg_names <- names(formals(constructor)) if (arg_names[[1]] != ".data") { stop("First argument to `constructor` must be .data", call. = FALSE) } if ("..." %in% arg_names) { stop("`constructor` can not use `...`", call. = FALSE) } } is_S3_class <- function(x) { inherits(x, "S7_S3_class") } # ------------------------------------------------------------------------- # Pull out validation functions so hit by code coverage validate_factor <- function(self) { c( if (typeof(self) != "integer") "Underlying data must be an ", if (!is.character(attr(self, "levels", TRUE))) "attr(, 'levels') must be a ", { rng <- range(0L, unclass(self)); NULL }, if (rng[1] < 0L) "Underlying data must be all positive", if (rng[2] > length(attr(self, "levels", TRUE))) "Not enough 'levels' for underlying data" ) } validate_date <- function(self) { c( if (mode(self) != "numeric") "Underlying data must be numeric", if (!inherits(self, "Date")) "Underlying data must have class 'Date'" ) } validate_POSIXct <- function(self) { if (mode(self) != "numeric") { return("Underlying data must be numeric") } tz <- attr(self, "tz") if (!is.character(tz) || length(tz) != 1) { return("attr(, 'tz') must be a single string") } } validate_POSIXlt <- function(self) { tryCatch({ format(self) # calls valid_POSIXlt() in C invisible(NULL) }, error = function(e) conditionMessage(e)) } validate_data.frame <- function(self) { if (!is.list(self)) { return("Underlying data must be a ") } if (length(self) >= 1) { # Avoid materialising compact row names ns <- unique(c(lengths(self), .row_names_info(self, 2L))) if (length(ns) > 1) { return("All columns and row names must have the same length") } if (is.null(names(self))) { return("Underlying data must be named") } } } valid_dimnames <- function(self) { dn <- dimnames(self) if (is.null(dn)) TRUE else if (!is.list(dn) || length(dn) != length(dim(self))) FALSE else for (i in seq_along(dimnames(self))) { if (is.null(dn[[i]])) next if (!is.character(dn[[i]]) || length(dn[[i]]) != dim(self)[[i]]) return(FALSE) } TRUE } validate_matrix <- function(self) { if (!is.matrix(self)) { # is.matrix() methods should only return TRUE if valid "is.matrix(self) is FALSE" } else if (!is.integer(dim(self)) || length(dim(self)) != 2L || !all(dim(self) >= 0L)) { "dim(self) must be a non-negative integer vector of length 2" } else if (!valid_dimnames(self)) { "dimnames(self) must be NULL or a length 2 list of either NULL or a character vector of length equal to its corresponding dimension" } } validate_array <- function(self) { if (is.array(self)) # is.array() methods should only return TRUE if valid return(invisible(NULL)) if (!is.integer(dim(self)) || length(dim(self)) == 0L || !all(dim(self) >= 0L)) return("dim(self) must be a non-empty non-negative integer vector") if (!valid_dimnames(self)) return("dimnames(self) must be NULL or a list of either NULL or a character vector of length equal to its corresponding dimension") "is.array(self) is FALSE" } validate_formula <- function(self) { if (is.null(environment(self))) return("environment(self) must be non-NULL") if (identical(self, stats::formula(NULL, environment(self)))) # weird NULL case return(invisible(NULL)) if (!is.call(self) || !length(self) %in% 2:3 || unclass(self)[[1L]] != quote(`~`)) return("must be a call to `~` of length 2 or 3") } #' S7 wrappers for key S3 classes #' #' @description #' S7 bundles [S3 definitions][new_S3_class] for key S3 classes provided by #' the base packages: #' #' * `class_data.frame` for data frames. #' * `class_Date` for dates. #' * `class_factor` for factors. #' * `class_POSIXct`, `class_POSIXlt` and `class_POSIXt` for date-times. # * `class_matrix` for matrices. # * `class_array` for arrays. #' * `class_formula` for formulas. #' #' @export #' @name base_s3_classes #' @format NULL #' @order 3 class_factor <- new_S3_class("factor", constructor = function(.data = integer(), levels = NULL) { levels <- levels %||% attr(.data, "levels", TRUE) %||% character() structure(.data, levels = levels, class = "factor") }, validator = validate_factor ) #' @export #' @rdname base_s3_classes #' @format NULL #' @order 3 class_Date <- new_S3_class("Date", constructor = function(.data = double()) { .Date(.data) }, validator = validate_date ) #' @export #' @rdname base_s3_classes #' @format NULL #' @order 3 class_POSIXct <- new_S3_class(c("POSIXct", "POSIXt"), constructor = function(.data = double(), tz = "") { .POSIXct(.data, tz = tz) }, validator = validate_POSIXct ) #' @export #' @rdname base_s3_classes #' @format NULL #' @order 3 class_POSIXlt <- new_S3_class(c("POSIXlt", "POSIXt"), constructor = function(.data = NULL, tz = "") { as.POSIXlt(.data, tz = tz) }, validator = validate_POSIXlt ) #' @export #' @rdname base_s3_classes #' @format NULL #' @order 3 class_POSIXt <- new_S3_class("POSIXt") # abstract class #' @export #' @rdname base_s3_classes #' @format NULL #' @order 3 class_data.frame <- new_S3_class("data.frame", constructor = function(.data = list(), row.names = NULL) { if (is.null(row.names)) { list2DF(.data) } else { out <- list2DF(.data, length(row.names)) attr(out, "row.names") <- row.names out } }, validator = validate_data.frame ) # @export # @rdname base_s3_classes # @format NULL # @order 3 class_matrix <- new_S3_class("matrix", constructor = function(.data = logical(), nrow = NULL, ncol = NULL, byrow = FALSE, dimnames = NULL) { nrow <- nrow %||% NROW(.data) if(is.null(ncol)) { ncol <- NCOL(.data) if(length(.data) != (nrow * ncol)) { ncol <- length(.data) %/% nrow } } matrix(.data, nrow, ncol, byrow, dimnames) }, validator = validate_matrix ) # @export # @rdname base_s3_classes # @format NULL # @order 3 class_array <- new_S3_class("array", constructor = function(.data = logical(), dim = base::dim(.data) %||% length(.data), dimnames = base::dimnames(.data)) { array(.data, dim, dimnames) }, validator = validate_array ) #' @export #' @rdname base_s3_classes #' @format NULL #' @order 3 class_formula <- new_S3_class("formula", constructor = function(.data = NULL, env = parent.frame()) { stats::formula(.data, env = env) }, validator = validate_formula ) S7/R/class.R0000644000176200001440000002475714712423107012214 0ustar liggesusers#' Define a new S7 class #' #' @description #' A class specifies the properties (data) that each of its objects will #' possess. The class, and its parent, determines which method will be used #' when an object is passed to a generic. #' #' Learn more in `vignette("classes-objects")` #' #' @param name The name of the class, as a string. The result of calling #' `new_class()` should always be assigned to a variable with this name, #' i.e. `Foo <- new_class("Foo")`. #' @param parent The parent class to inherit behavior from. #' There are three options: #' #' * An S7 class, like [S7_object]. #' * An S3 class wrapped by [new_S3_class()]. #' * A base type, like [class_logical], [class_integer], etc. #' @param package Package name. This is automatically resolved if the class is #' defined in a package, and `NULL` otherwise. #' #' Note, if the class is intended for external use, the constructor should be #' exported. Learn more in `vignette("packages")`. #' @param abstract Is this an abstract class? An abstract class can not be #' instantiated. #' @param constructor The constructor function. In most cases, you can rely #' on the default constructor, which will generate a function with one #' argument for each property. #' #' A custom constructor should call `new_object()` to create the S7 object. #' The first argument, `.data`, should be an instance of the parent class #' (if used). The subsequent arguments are used to set the properties. #' @param validator A function taking a single argument, `self`, the object #' to validate. #' #' The job of a validator is to determine whether the object is valid, #' i.e. if the current property values form an allowed combination. The #' types of the properties are always automatically validated so the job of #' the validator is to verify that the _values_ of individual properties are #' ok (i.e. maybe a property should have length 1, or should always be #' positive), or that the _combination_ of values of multiple properties is ok. #' It is called after construction and whenever any property is set. #' #' The validator should return `NULL` if the object is valid. If not, it #' should return a character vector where each element describes a single #' problem, using `@prop_name` to describe where the problem lies. #' #' See `validate()` for more details, examples, and how to temporarily #' suppress validation when needed. #' @param properties A named list specifying the properties (data) that #' belong to each instance of the class. Each element of the list can #' either be a type specification (processed by [as_class()]) or a #' full property specification created [new_property()]. #' @return A object constructor, a function that can be used to create objects #' of the given class. #' @export #' @examples #' # Create an class that represents a range using a numeric start and end #' Range <- new_class("Range", #' properties = list( #' start = class_numeric, #' end = class_numeric #' ) #' ) #' r <- Range(start = 10, end = 20) #' r #' # get and set properties with @ #' r@start #' r@end <- 40 #' r@end #' #' # S7 automatically ensures that properties are of the declared types: #' try(Range(start = "hello", end = 20)) #' #' # But we might also want to use a validator to ensure that start and end #' # are length 1, and that start is < end #' Range <- new_class("Range", #' properties = list( #' start = class_numeric, #' end = class_numeric #' ), #' validator = function(self) { #' if (length(self@start) != 1) { #' "@start must be a single number" #' } else if (length(self@end) != 1) { #' "@end must be a single number" #' } else if (self@end < self@start) { #' "@end must be great than or equal to @start" #' } #' } #' ) #' try(Range(start = c(10, 15), end = 20)) #' try(Range(start = 20, end = 10)) #' #' r <- Range(start = 10, end = 20) #' try(r@start <- 25) new_class <- function( name, parent = S7_object, package = topNamespaceName(parent.frame()), properties = list(), abstract = FALSE, constructor = NULL, validator = NULL) { check_name(name) parent <- as_class(parent) # Don't check arguments for S7_object if (!is.null(parent)) { check_can_inherit(parent) if (!is.null(package)) { check_name(package) } if (!is.null(constructor)) { check_S7_constructor(constructor) } if (!is.null(validator)) { check_function(validator, alist(self = )) } if (abstract && (!is_class(parent) || !(parent@abstract || parent@name == "S7_object"))) { stop("Abstract classes must have abstract parents") } } # Combine properties from parent, overriding as needed all_props <- attr(parent, "properties", exact = TRUE) %||% list() new_props <- as_properties(properties) check_prop_names(new_props) all_props[names(new_props)] <- new_props if (is.null(constructor)) { constructor <- new_constructor(parent, all_props, envir = parent.frame(), package = package) } object <- constructor # Must synchronise with prop_names attr(object, "name") <- name attr(object, "parent") <- parent attr(object, "package") <- package attr(object, "properties") <- all_props attr(object, "abstract") <- abstract attr(object, "constructor") <- constructor attr(object, "validator") <- validator class(object) <- c("S7_class", "S7_object") global_variables(names(all_props)) object } globalVariables(c("name", "parent", "package", "properties", "abstract", "constructor", "validator")) #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name) S7_class_name <- function(x) { paste(c(x@package, x@name), collapse = "::") } check_S7_constructor <- function(constructor) { if (!is.function(constructor)) { stop("`constructor` must be a function", call. = FALSE) } method_call <- find_call(body(constructor), quote(new_object), packageName()) if (is.null(method_call)) { stop("`constructor` must contain a call to `new_object()`", call. = FALSE) } } #' @export print.S7_class <- function(x, ...) { props <- x@properties if (length(props) > 0) { prop_names <- format(names(props)) prop_types <- format(vcapply(props, function(x) class_desc(x$class))) prop_fmt <- paste0(" $ ", prop_names, ": ", prop_types, "\n", collapse = "") } else { prop_fmt <- "" } cat( sprintf( paste0( "%s%s class\n", "@ parent : %s\n", "@ constructor: %s\n", "@ validator : %s\n", "@ properties :\n%s" ), class_desc(x), if (x@abstract) " abstract" else "", class_desc(x@parent), show_function(x@constructor, constructor = TRUE), if (!is.null(x@validator)) show_function(x@validator) else "", prop_fmt ), sep = "" ) invisible(x) } #' @export str.S7_class <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") cat("<", paste0(class_dispatch(object), collapse = "/"), "> constructor", sep = "") cat("\n") if (nest.lev == 0) { str_nest(props(object), "@", ..., nest.lev = nest.lev) } } #' @export c.S7_class <- function(...) { msg <- "Can not combine S7 class objects" stop(msg, call. = FALSE) } can_inherit <- function(x) is_base_class(x) || is_S3_class(x) || is_class(x) check_can_inherit <- function(x, arg = deparse(substitute(x))) { if (!can_inherit(x)) { msg <- sprintf( "`%s` must be an S7 class, S3 class, or base type, not %s.", arg, class_friendly(x) ) stop(msg, call. = FALSE) } if (is_base_class(x) && x$class == "environment") { stop("Can't inherit from an environment.", call. = FALSE) } } is_class <- function(x) inherits(x, "S7_class") # Object ------------------------------------------------------------------ #' @param .parent,... Parent object and named properties used to construct the #' object. #' @rdname new_class #' @export new_object <- function(.parent, ...) { class <- sys.function(-1) if (!inherits(class, "S7_class")) { stop("`new_object()` must be called from within a constructor") } if (class@abstract) { msg <- sprintf("Can't construct an object from abstract class <%s>", class@name) stop(msg) } # force .parent before ... # TODO: Some type checking on `.parent`? object <- .parent args <- list(...) if ("" %in% names2(args)) { stop("All arguments to `...` must be named") } has_setter <- vlapply(class@properties[names(args)], prop_has_setter) attrs <- c( list(class = class_dispatch(class), S7_class = class), args[!has_setter], attributes(object) ) attrs <- attrs[!duplicated(names(attrs))] attributes(object) <- attrs # invoke custom property setters prop_setter_vals <- args[has_setter] for (name in names(prop_setter_vals)) prop(object, name, check = FALSE) <- prop_setter_vals[[name]] # Don't need to validate if parent class already validated, # i.e. it's a non-abstract S7 class parent_validated <- inherits(class@parent, "S7_object") && !class@parent@abstract validate(object, recursive = !parent_validated) object } #' @export print.S7_object <- function(x, ...) { str(x, ...) invisible(x) } #' @export str.S7_object <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") cat(obj_desc(object)) if (!is_S7_type(object)) { if (!typeof(object) %in% c("numeric", "integer", "character", "double")) cat(" ") attrs <- attributes(object) if (is.environment(object)) { attributes(object) <- NULL } else { attributes(object) <- list(names = names(object), dim = dim(object)) } str(object, nest.lev = nest.lev) attributes(object) <- attrs } else { cat("\n") } str_nest(props(object), "@", ..., nest.lev = nest.lev) } #' Retrieve the S7 class of an object #' #' Given an S7 object, find it's class. #' #' @param object The S7 object #' @returns An [S7 class][new_class]. #' @export #' @examples #' Foo <- new_class("Foo") #' S7_class(Foo()) S7_class <- function(object) { attr(object, "S7_class", exact = TRUE) } check_prop_names <- function(properties, error_call = sys.call(-1L)) { # these attributes have special C handlers in base R forbidden <- c("names", "dim", "dimnames", "class", "tsp", "comment", "row.names", "...") forbidden <- intersect(forbidden, names(properties)) if (length(forbidden)) { msg <- paste0("property can't be named: ", paste0(forbidden, collapse = ", ")) stop(simpleError(msg, error_call)) } } S7/R/class-spec.R0000644000176200001440000002120714712423107013127 0ustar liggesusers#' Standard class specifications #' #' This is used as the interface between S7 and R's other OO systems, allowing #' you to use S7 classes and methods with base types, informal S3 classes, and #' formal S4 classes. #' #' @param x A class specification. One of the following: #' * An S7 class (created by [new_class()]). #' * An S7 union (created by [new_union()]). #' * An S3 class (created by [new_S3_class()]). #' * An S4 class (created by [methods::getClass()] or [methods::new()]). #' * A base class, like [class_logical], [class_integer], or [class_double]. #' * A "special", either [class_missing] or [class_any]. #' @param arg Argument name used when generating errors. #' @keywords internal #' @export #' @return A standardised class: either `NULL`, an S7 class, an S7 union, #' as [new_S3_class], or a S4 class. #' @examples #' as_class(class_logical) #' as_class(new_S3_class("factor")) as_class <- function(x, arg = deparse(substitute(x))) { error_base <- sprintf("Can't convert `%s` to a valid class. ", arg) if (is_foundation_class(x)) { x } else if (is.null(x)) { # NULL is handled specially because you can't assign a class to it, # so it can't be wrapped in new_base_class x } else if (isS4(x)) { S4_to_S7_class(x, error_base) } else { msg <- sprintf("Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a %s.", obj_desc(x)) stop(paste0(error_base, msg), call. = FALSE) } } is_foundation_class <- function(x) { is_class(x) || is_union(x) || is_base_class(x) || is_S3_class(x) || is_class_missing(x) || is_class_any(x) } class_type <- function(x) { if (is.null(x)) { "NULL" } else if (is_class_missing(x)) { "missing" } else if (is_class_any(x)) { "any" } else if (is_base_class(x)) { "S7_base" } else if (is_class(x)) { "S7" } else if (is_union(x)) { "S7_union" } else if (is_S3_class(x)) { "S7_S3" } else if (is_S4_class(x)) { "S4" } else { stop("`x` is not standard S7 class", call. = FALSE) } } class_friendly <- function(x) { switch(class_type(x), NULL = "NULL", missing = "a missing argument", any = "any type", S4 = "an S4 class", S7 = "an S7 class", S7_base = "a base type", S7_union = "an S7 union", S7_S3 = "an S3 class", ) } class_construct <- function(.x, ...) { class_constructor(.x)(...) } class_construct_expr <- function(.x, envir = NULL, package = NULL) { f <- class_constructor(.x) # For S7 class constructors with a non-NULL @package property # Instead of inlining the full class definition, use either # `pkgname::classname()` or `classname()` if (is_class(f) && !is.null(f@package)) { # Check if the class can be resolved as a bare symbol without pkgname:: # Note: During package build, using pkg::class for a package's own symbols # will raise an error from `::`. if (identical(package, f@package)) { return(call(f@name)) } else { # namespace the pkgname::classname() call cl <- as.call(list(quote(`::`), as.name(f@package), as.name(f@name))) # check the call evaluates to f. # This will error if package is not installed or object is not exported. f2 <- eval(cl, baseenv()) if (!identical(f, f2)) { msg <- sprintf( "`%s::%s` is not identical to the class with the same @package and @name properties", f@package, f@name ) stop(msg, call. = FALSE) } return(as.call(list(cl))) } } # If the constructor is a closure wrapping a simple expression, try # to extract the expression # (mostly for nicer printing and introspection.) # can't unwrap if the closure is potentially important # (this can probably be relaxed to allow additional environments) fe <- environment(f) if (!identical(fe, baseenv())) { return(as.call(list(f))) } # special case for `class_missing` if (identical(body(f) -> fb, quote(expr =))) { return(quote(expr =)) } # `new_object()` must be called from the class constructor, can't # be safely unwrapped if ("new_object" %in% all.names(fb)) { return(as.call(list(f))) } # maybe unwrap body if it is a single expression wrapped in `{` if (length(fb) == 2L && identical(fb[[1L]], quote(`{`))) fb <- fb[[2L]] # If all the all the work happens in the promise to the `.data` arg, # return the `.data` expression. ff <- formals(f) if ((identical(fb, quote(.data))) && identical(names(ff), ".data")) { return(ff$.data) } # if all the work happens in the function body, return the body. if (is.null(ff)) { return(fb) } #else, return a call to the constructor as.call(list(f)) } class_constructor <- function(.x) { switch(class_type(.x), any = , NULL = new_function(env = baseenv()), missing = new_function(, quote(expr =), baseenv()), S4 = function(...) methods::new(.x, ...), S7 = .x, S7_base = .x$constructor, S7_union = class_constructor(.x$classes[[1]]), S7_S3 = .x$constructor, stop(sprintf("Can't construct %s", class_friendly(.x)), call. = FALSE) ) } class_validate <- function(class, object) { validator <- switch(class_type(class), S4 = methods::validObject, S7 = class@validator, S7_base = class$validator, S7_S3 = class$validator, NULL ) if (is.null(validator)) { NULL } else { validator(object) } } class_desc <- function(x) { switch(class_type(x), NULL = "", missing = "", any = "", S4 = paste0("S4<", x@className, ">"), S7 = paste0("<", S7_class_name(x), ">"), S7_base = paste0("<", x$class, ">"), S7_union = oxford_or(unlist(lapply(x$classes, class_desc))), S7_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"), ) } # Vector of class names; used in method introspection class_dispatch <- function(x) { if (is_class(x) && x@name == "S7_object") { return("S7_object") } switch(class_type(x), NULL = "NULL", missing = "MISSING", any = character(), S4 = S4_class_dispatch(methods::extends(x)), S7 = c(S7_class_name(x), class_dispatch(x@parent)), S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), stop("Unsupported") ) } # Class name when registering an S7 method class_register <- function(x) { switch(class_type(x), NULL = "NULL", missing = "MISSING", any = "ANY", S4 = S4_class_name(x), S7 = S7_class_name(x), S7_base = x$class, S7_S3 = x$class[[1]], stop("Unsupported") ) } # Used when printing method signature to generate executable code class_deparse <- function(x) { switch(class_type(x), "NULL" = "NULL", missing = "class_missing", any = "class_any", S4 = as.character(x@className), S7 = S7_class_name(x), S7_base = paste0("class_", x$class), S7_union = { classes <- vcapply(x$classes, class_deparse) paste0("new_union(", paste(classes, collapse = ", "), ")") }, S7_S3 = paste0("new_S3_class(", deparse1(x$class), ")"), ) } class_inherits <- function(x, what) { switch(class_type(what), "NULL" = is.null(x), missing = FALSE, any = TRUE, S4 = isS4(x) && methods::is(x, what), S7 = inherits(x, "S7_object") && inherits(x, S7_class_name(what)), S7_base = what$class == base_class(x), S7_union = any(vlapply(what$classes, class_inherits, x = x)), # This is slightly too crude as we really want them to be in the same # order and contiguous, but it's probably close enough for practical # purposes S7_S3 = !isS4(x) && all(what$class %in% class(x)), ) } obj_type <- function(x) { if (identical(x, quote(expr = ))) { "missing" } else if (inherits(x, "S7_object")) { "S7" } else if (isS4(x)) { "S4" } else if (is.object(x)) { "S3" } else { "base" } } obj_desc <- function(x) { switch(obj_type(x), missing = "MISSING", base = paste0("<", typeof(x), ">"), S3 = paste0("S3<", paste(class(x), collapse = "/"), ">"), S4 = paste0("S4<", class(x), ">"), S7 = paste0("<", class(x)[[1]], ">") ) } obj_dispatch <- function(x) { switch(obj_type(x), missing = "MISSING", base = base_class(x), S3 = class(x), S4 = S4_class_dispatch(methods::getClass(class(x))), S7 = class(x) # = class_dispatch(S7_class(x)) ) } base_class <- function(x) { switch(typeof(x), closure = "function", special = "function", builtin = "function", language = "call", symbol = "name", typeof(x) ) } # helpers ----------------------------------------------------------------- # Suppress @className false positive globalVariables("className") S7/R/method-ops.R0000644000176200001440000000240714632312260013150 0ustar liggesusersbase_ops <- NULL base_matrix_ops <- NULL on_load_define_ops <- function() { base_ops <<- lapply( setNames(, group_generics()$Ops), new_generic, dispatch_args = c("e1", "e2") ) base_matrix_ops <<- lapply( setNames(, group_generics()$matrixOps), new_generic, dispatch_args = c("x", "y") ) } #' @export Ops.S7_object <- function(e1, e2) { cnd <- tryCatch( return(base_ops[[.Generic]](e1, e2)), S7_error_method_not_found = function(cnd) cnd ) if (S7_inherits(e1) && S7_inherits(e2)) { stop(cnd) } else { # Must call NextMethod() directly in the method, not wrapped in an # anonymous function. NextMethod() } } #' @rawNamespace if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_object) chooseOpsMethod.S7_object <- function(x, y, mx, my, cl, reverse) TRUE #' @rawNamespace if (getRversion() >= "4.3.0") S3method(matrixOps, S7_object) matrixOps.S7_object <- function(x, y) { base_matrix_ops[[.Generic]](x, y) } #' @export Ops.S7_super <- Ops.S7_object #' @rawNamespace if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_super) chooseOpsMethod.S7_super <- chooseOpsMethod.S7_object #' @rawNamespace if (getRversion() >= "4.3.0") S3method(matrixOps, S7_super) matrixOps.S7_super <- matrixOps.S7_object S7/R/union.R0000644000176200001440000000604714513567553012244 0ustar liggesusers#' Define a class union #' #' @description #' A class union represents a list of possible classes. You can create it #' with `new_union(a, b, c)` or `a | b | c`. Unions can be used in two #' places: #' #' * To allow a property to be one of a set of classes, #' `new_property(class_integer | Range)`. The default `default` value for the #' property will be the constructor of the first object in the union. #' This means if you want to create an "optional" property (i.e. one that #' can be `NULL` or of a specified type), you'll need to write (e.g.) #' `NULL | class_integer`. #' #' * As a convenient short-hand to define methods for multiple classes. #' `method(foo, X | Y) <- f` is short-hand for #' `method(foo, X) <- f; method(foo, Y) <- foo` #' #' S7 includes built-in unions for "numeric" (integer and double vectors), #' "atomic" (logical, numeric, complex, character, and raw vectors) and #' "vector" (atomic vectors, lists, and expressions). #' #' @param ... The classes to include in the union. See [as_class()] for #' details. #' @return An S7 union, i.e. a list with class `S7_union`. #' @export #' @examples #' logical_or_character <- new_union(class_logical, class_character) #' logical_or_character #' # or with shortcut syntax #' logical_or_character <- class_logical | class_character #' #' Foo <- new_class("Foo", properties = list(x = logical_or_character)) #' Foo(x = TRUE) #' Foo(x = letters[1:5]) #' try(Foo(1:3)) #' #' bar <- new_generic("bar", "x") #' # Use built-in union #' method(bar, class_atomic) <- function(x) "Hi!" #' bar #' bar(TRUE) #' bar(letters) #' try(bar(NULL)) new_union <- function(...) { classes <- class_flatten(list(...)) out <- list(classes = classes) class(out) <- "S7_union" out } #' @export `|.S7_class` <- function(e1, e2) { new_union(e1, e2) } # Register remaining methods onLoad so that their pointers are identical, # working around a bug that was fixed in R 4.1: # https://github.com/wch/r-source/commit/b41344e3d0da7d78fd on_load_define_or_methods <- function() { registerS3method("|", "S7_union", `|.S7_class`) registerS3method("|", "S7_base_class", `|.S7_class`) registerS3method("|", "S7_S3_class", `|.S7_class`) registerS3method("|", "S7_any", `|.S7_class`) registerS3method("|", "S7_missing", `|.S7_class`) registerS3method("|", "classGeneratorFunction", `|.S7_class`) registerS3method("|", "ClassUnionRepresentation", `|.S7_class`) registerS3method("|", "classRepresentation", `|.S7_class`) } is_union <- function(x) inherits(x, "S7_union") #' @export print.S7_union <- function(x, ...) { cat(": ", class_desc(x), "\n", sep = "") invisible(x) } #' @export str.S7_union <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") print(object) } class_flatten <- function(x) { x <- lapply(x, as_class) # Flatten unions is_union <- vlapply(x, is_union) x[!is_union] <- lapply(x[!is_union], list) x[is_union] <- lapply(x[is_union], function(x) x$classes) unique(unlist(x, recursive = FALSE, use.names = FALSE)) } # See .onLoad() for definition base_unions <- list() S7/R/S7-package.R0000644000176200001440000000025514533115246012757 0ustar liggesusers## usethis namespace: start #' @importFrom utils globalVariables #' @importFrom utils head str hasName #' @useDynLib S7, .registration = TRUE ## usethis namespace: end NULL S7/R/aaa.R0000644000176200001440000000143414712423107011614 0ustar liggesusers `%||%` <- function(x, y) if (is.null(x)) y else x new_function <- function(args = NULL, body = NULL, env = asNamespace("S7")) { as.function.default(c(args, body) %||% list(NULL), env) } `append<-` <- function(x, after, value) { if (missing(after)) c(x, value) else append(x, value, after = after) } `append1<-` <- function (x, value) { stopifnot(is.list(x) || identical(mode(x), mode(value))) x[[length(x) + 1L]] <- value x } topNamespaceName <- function(env = parent.frame()) { env <- topenv(env) if (!isNamespace(env)) { return() # print visible } as.character(getNamespaceName(env)) # unname } is_string <- function(x) { identical(class(x), "character") && length(x) == 1L && !is.na(x) && x != "" } S7/R/super.R0000644000176200001440000000771614712423107012241 0ustar liggesusers#' Force method dispatch to use a superclass #' #' @description #' `super(from, to)` causes the dispatch for the next generic to use the method #' for the superclass `to` instead of the actual class of `from`. It's needed #' when you want to implement a method in terms of the implementation of its #' superclass. #' #' ## S3 & S4 #' `super()` performs a similar role to [NextMethod()] in S3 or #' [methods::callNextMethod()] in S4, but is much more explicit: #' #' * The super class that `super()` will use is known when write `super()` #' (i.e. statically) as opposed to when the generic is called #' (i.e. dynamically). #' #' * All arguments to the generic are explicit; they are not automatically #' passed along. #' #' This makes `super()` more verbose, but substantially easier to #' understand and reason about. #' #' ## `super()` in S3 generics #' #' Note that you can't use `super()` in methods for an S3 generic. #' For example, imagine that you have made a subclass of "integer": #' #' ```{r} #' MyInt <- new_class("MyInt", parent = class_integer, package = NULL) #' ``` #' #' Now you go to write a custom print method: #' #' ```{r} #' method(print, MyInt) <- function(x, ...) { #' cat("") #' print(super(x, to = class_integer)) #' } #' #' MyInt(10L) #' ``` #' #' This doesn't work because `print()` isn't an S7 generic so doesn't #' understand how to interpret the special object that `super()` produces. #' While you could resolve this problem with [NextMethod()] (because S7 is #' implemented on top of S3), we instead recommend using [S7_data()] to extract #' the underlying base object: #' #' ```{r} #' method(print, MyInt) <- function(x, ...) { #' cat("") #' print(S7_data(x)) #' } #' #' MyInt(10L) #' ``` #' #' @param from An S7 object to cast. #' @param to An S7 class specification, passed to [as_class()]. Must be a #' superclass of `object`. #' @returns An `S7_super` object which should always be passed #' immediately to a generic. It has no other special behavior. #' @export #' @examples #' Foo1 <- new_class("Foo1", properties = list(x = class_numeric, y = class_numeric)) #' Foo2 <- new_class("Foo2", Foo1, properties = list(z = class_numeric)) #' #' total <- new_generic("total", "x") #' method(total, Foo1) <- function(x) x@x + x@y #' #' # This won't work because it'll be stuck in an infinite loop: #' method(total, Foo2) <- function(x) total(x) + x@z #' #' # We could write #' method(total, Foo2) <- function(x) x@x + x@y + x@z #' # but then we'd need to remember to update it if the implementation #' # for total() ever changed. #' #' # So instead we use `super()` to call the method for the parent class: #' method(total, Foo2) <- function(x) total(super(x, to = Foo1)) + x@z #' total(Foo2(1, 2, 3)) #' #' # To see the difference between convert() and super() we need a #' # method that calls another generic #' #' bar1 <- new_generic("bar1", "x") #' method(bar1, Foo1) <- function(x) 1 #' method(bar1, Foo2) <- function(x) 2 #' #' bar2 <- new_generic("bar2", "x") #' method(bar2, Foo1) <- function(x) c(1, bar1(x)) #' method(bar2, Foo2) <- function(x) c(2, bar1(x)) #' #' obj <- Foo2(1, 2, 3) #' bar2(obj) #' # convert() affects every generic: #' bar2(convert(obj, to = Foo1)) #' # super() only affects the _next_ call to a generic: #' bar2(super(obj, to = Foo1)) super <- function(from, to) { check_is_S7(from) to <- as_class(to) check_can_inherit(to) if (!class_inherits(from, to)) { msg <- sprintf( "%s doesn't inherit from %s", obj_desc(from), class_desc(to) ) stop(msg) } # Must not change order of these fields as C code indexes by position structure( list( object = from, dispatch = class_dispatch(to) ), class = "S7_super" ) } #' @export print.S7_super <- function(x, ...) { str(x, ...) invisible(x) } #' @export str.S7_super <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") cat("super(", obj_desc(object$object), ", <", object$dispatch[[1]], ">)", sep = "") } S7/R/convert.R0000644000176200001440000001336614712423107012561 0ustar liggesusers#' Convert an object from one type to another #' #' @description #' `convert(from, to)` is a built-in generic for converting an object from #' one type to another. It is special in three ways: #' #' * It uses double-dispatch, because conversion depends on both `from` and #' `to`. #' #' * It uses non-standard dispatch because `to` is a class, not an object. #' #' * It doesn't use inheritance for the `to` argument. To understand #' why, imagine you have written methods to objects of various types to #' `classParent`. If you then create a new `classChild` that inherits from #' `classParent`, you can't expect the methods written for `classParent` #' to work because those methods will return `classParent` objects, not #' `classChild` objects. #' #' `convert()` provides two default implementations: #' #' 1. When `from` inherits from `to`, it strips any properties that `from` #' possesses that `to` does not (downcasting). #' 2. When `to` is a subclass of `from`'s class, it creates a new object of #' class `to`, copying over existing properties from `from` and initializing #' new properties of `to` (upcasting). #' #' If you are converting an object solely for the purposes of accessing a method #' on a superclass, you probably want [super()] instead. See its docs for more #' details. #' #' ## S3 & S4 #' #' `convert()` plays a similar role to the convention of defining `as.foo()` #' functions/generics in S3, and to `as()`/`setAs()` in S4. #' #' @param from An S7 object to convert. #' @param to An S7 class specification, passed to [as_class()]. #' @param ... Other arguments passed to custom `convert()` methods. For upcasting, #' these can be used to override existing properties or set new ones. #' @return Either `from` coerced to class `to`, or an error if the coercion #' is not possible. #' @export #' @examples #' Foo1 <- new_class("Foo1", properties = list(x = class_integer)) #' Foo2 <- new_class("Foo2", Foo1, properties = list(y = class_double)) #' #' # Downcasting: S7 provides a default implementation for coercing an object #' # to one of its parent classes: #' convert(Foo2(x = 1L, y = 2), to = Foo1) #' #' # Upcasting: S7 also provides a default implementation for coercing an object #' # to one of its child classes: #' convert(Foo1(x = 1L), to = Foo2) #' convert(Foo1(x = 1L), to = Foo2, y = 2.5) # Set new property #' convert(Foo1(x = 1L), to = Foo2, x = 2L, y = 2.5) # Override existing and set new #' #' # For all other cases, you'll need to provide your own. #' try(convert(Foo1(x = 1L), to = class_integer)) #' #' method(convert, list(Foo1, class_integer)) <- function(from, to) { #' from@x #' } #' convert(Foo1(x = 1L), to = class_integer) #' #' # Note that conversion does not respect inheritance so if we define a #' # convert method for integer to foo1 #' method(convert, list(class_integer, Foo1)) <- function(from, to) { #' Foo1(x = from) #' } #' convert(1L, to = Foo1) #' #' # Converting to Foo2 will still error #' try(convert(1L, to = Foo2)) #' # This is probably not surprising because foo2 also needs some value #' # for `@y`, but it definitely makes dispatch for convert() special convert <- function(from, to, ...) { to <- as_class(to) check_can_inherit(to) dispatch <- list(obj_dispatch(from), class_register(to)) convert <- .Call(method_, convert, dispatch, environment(), FALSE) if (!is.null(convert)) { convert(from, to, ...) } else if (class_inherits(from, to)) { from_class <- S7_class(from) if (is.null(from_class)) { from_props <- character() } else { from_props <- names(from_class@properties) } if (is_base_class(to)) { from <- zap_attr(from, c(from_props, "S7_class", "class")) } else if (is_S3_class(to)) { from <- zap_attr(from, c(from_props, "S7_class")) class(from) <- to$class } else if (is_class(to)) { from <- zap_attr(from, setdiff(from_props, names(to@properties))) attr(from, "S7_class") <- to class(from) <- class_dispatch(to) } else { stop("Unreachable") } from } else if (is_parent_instance(from, to)) { # We're up-casting, using `from` as a prototype/seed when constructing `to`. # Essentially, we copy over property values from `from` and supply them as # arguments to the `to` constructor. # Get properties of 'from' class from_props <- S7_class(from)@properties # Remove read-only properties from_props <- Filter(Negate(prop_is_read_only), from_props) from_prop_names <- names(from_props) # Check if 'to' constructor can accept all properties to_constructor_arg_names <- names(formals(to)) if (!"..." %in% to_constructor_arg_names) { # If no ..., only use properties that match constructor arguments from_prop_names <- intersect(from_prop_names, to_constructor_arg_names) } # Remove properties that are overridden in user-supplied arguments user_args <- list(...) from_prop_names <- setdiff(from_prop_names, names(user_args)) # Extract property values from 'from' from_prop_values <- props(from, from_prop_names) # Combine property values with user-supplied arguments constructor_args <- c(from_prop_values, user_args) # Create and return new object of class 'to' do.call(to, constructor_args) } else { msg <- paste0( "Can't find method for generic `convert()` with dispatch classes:\n", "- from: ", obj_desc(from), "\n", "- to : ", class_desc(to), "\n" ) stop(msg, call. = FALSE) } } # Converted to S7_generic onLoad in order to avoid dependency between files on_load_make_convert_generic <- function() { convert <<- S7_generic( convert, name = "convert", dispatch_args = c("from", "to") ) } is_parent_instance <- function(x, class) { inherits(x, setdiff(class_dispatch(class), "S7_object")) } S7/R/special.R0000644000176200001440000000272114675323445012526 0ustar liggesusers#' Dispatch on a missing argument #' #' Use `class_missing` to dispatch when the user has not supplied an argument, #' i.e. it's missing in the sense of [missing()], not in the sense of #' [is.na()]. #' #' @export #' @return Sentinel objects used for special types of dispatch. #' @format NULL #' @examples #' foo <- new_generic("foo", "x") #' method(foo, class_numeric) <- function(x) "number" #' method(foo, class_missing) <- function(x) "missing" #' method(foo, class_any) <- function(x) "fallback" #' #' foo(1) #' foo() #' foo("") class_missing <- structure(list(), class = "S7_missing") is_class_missing <- function(x) inherits(x, "S7_missing") #' @export print.S7_missing <- function(x, ...) { cat("\n") invisible(x) } #' @export str.S7_missing <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") print(object) } #' Dispatch on any class #' #' Use `class_any` to register a default method that is called when no other #' methods are matched. #' #' @export #' @format NULL #' @examples #' foo <- new_generic("foo", "x") #' method(foo, class_numeric) <- function(x) "number" #' method(foo, class_any) <- function(x) "fallback" #' #' foo(1) #' foo("x") class_any <- structure(list(), class = "S7_any") is_class_any <- function(x) inherits(x, "S7_any") #' @export print.S7_any <- function(x, ...) { cat("\n") invisible(x) } #' @export str.S7_any <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") print(object) } S7/R/zzz.R0000644000176200001440000000636514712423107011737 0ustar liggesusers#' Base S7 class #' #' The base class from which all S7 classes eventually inherit from. #' #' @keywords internal #' @export #' @return The base S7 object. #' @examples #' #' S7_object S7_object <- new_class( name = "S7_object", package = NULL, parent = NULL, constructor = function() { .Call(S7_object_) }, validator = function(self) { if (!is_S7_type(self)) { "Underlying data is corrupt" } } ) methods::setOldClass("S7_object") .S7_type <- NULL # Defined onLoad because it depends on R version on_load_define_S7_type <- function() { .S7_type <<- typeof(.Call(S7_object_)) } is_S7_type <- function(x) { typeof(x) == .S7_type } #' @export `$.S7_object` <- function(x, name) { if (typeof(x) %in% c("list", "environment")) { NextMethod() } else { msg <- sprintf( "Can't get S7 properties with `$`. Did you mean `%s@%s`?", deparse1(substitute(x)), name ) stop(msg, call. = FALSE) } } #' @export `$<-.S7_object` <- function(x, name, value) { if (typeof(x) %in% c("list", "environment")) { NextMethod() } else { msg <- sprintf( "Can't set S7 properties with `$`. Did you mean `...@%s <- %s`?", name, deparse1(substitute(value)) ) stop(msg, call. = FALSE) } } #' @export `[.S7_object` <- function(x, ..., drop = TRUE) { check_subsettable(x) NextMethod() } #' @export `[<-.S7_object` <- function(x, ..., value) { check_subsettable(x) NextMethod() } #' @export `[[.S7_object` <- function(x, ...) { check_subsettable(x, allow_env = TRUE) NextMethod() } #' @export `[[<-.S7_object` <- function(x, ..., value) { check_subsettable(x, allow_env = TRUE) NextMethod() } check_subsettable <- function(x, allow_env = FALSE) { allowed_types <- c("list", "language", "pairlist", if (allow_env) "environment") if (!typeof(x) %in% allowed_types) { stop("S7 objects are not subsettable.") } invisible(TRUE) } S7_generic <- NULL on_load_define_S7_generic <- function() { # we do this in .onLoad() because dynlib `prop_` symbol # is not available at pkg build time, and new_class() # errors if `@` is not usable. S7_generic <<- new_class( name = "S7_generic", package = NULL, properties = list( name = class_character, methods = class_environment, dispatch_args = class_character ), parent = class_function ) } methods::setOldClass(c("S7_generic", "function", "S7_object")) is_S7_generic <- function(x) inherits(x, "S7_generic") S7_method <- NULL on_load_define_S7_method <- function() { S7_method <<- new_class( "S7_method", package = NULL, parent = class_function, properties = list(generic = S7_generic, signature = class_list) ) } methods::setOldClass(c("S7_method", "function", "S7_object")) # hooks ------------------------------------------------------------------- .onAttach <- function(libname, pkgname) { env <- as.environment(paste0("package:", pkgname)) if (getRversion() < "4.3.0") { env[[".conflicts.OK"]] <- TRUE } } .onLoad <- function(...) { activate_backward_compatiblility() on_load_define_S7_generic() on_load_define_S7_method() on_load_make_convert_generic() on_load_define_ops() on_load_define_or_methods() on_load_define_S7_type() on_load_define_union_classes() } S7/R/generic.R0000644000176200001440000001560314712423107012511 0ustar liggesusers#' Define a new generic #' #' @description #' A generic function uses different implementations (_methods_) depending on #' the class of one or more arguments (the _signature_). Create a new generic #' with `new_generic()` then use [method<-] to add methods to it. #' #' Method dispatch is performed by `S7_dispatch()`, which must always be #' included in the body of the generic, but in most cases `new_generic()` will #' generate this for you. #' #' Learn more in `vignette("generics-methods")` #' #' @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 giving the names of one or more #' arguments used to find the method. #' @param fun An optional specification of the generic, which must call #' `S7_dispatch()` to dispatch to methods. This is usually generated #' automatically from the `dispatch_args`, but you may want to supply it if #' you want to add additional required arguments, omit `...`, or perform #' some standardised computation in the generic. #' #' The `dispatch_args` must be the first arguments to `fun`, and, if present, #' `...` must immediately follow them. #' @seealso [new_external_generic()] to define a method for a generic #' in another package without taking a strong dependency on it. #' @export #' @returns An S7 generic, i.e. a function with class `S7_generic`. #' @order 1 #' @examples #' # A simple generic with methods for some base types and S3 classes #' type_of <- new_generic("type_of", dispatch_args = "x") #' method(type_of, class_character) <- function(x, ...) "A character vector" #' method(type_of, new_S3_class("data.frame")) <- function(x, ...) "A data frame" #' method(type_of, class_function) <- function(x, ...) "A function" #' #' type_of(mtcars) #' type_of(letters) #' type_of(mean) #' #' # If you want to require that methods implement additional arguments, #' # you can use a custom function: #' mean2 <- new_generic("mean2", "x", function(x, ..., na.rm = FALSE) { #' S7_dispatch() #' }) #' #' method(mean2, class_numeric) <- function(x, ..., na.rm = FALSE) { #' if (na.rm) { #' x <- x[!is.na(x)] #' } #' sum(x) / length(x) #' } #' #' # You'll be warned if you forget the argument: #' method(mean2, class_character) <- function(x, ...) { #' stop("Not supported") #' } new_generic <- function(name, dispatch_args, fun = NULL) { check_name(name) dispatch_args <- check_dispatch_args(dispatch_args, fun) if (is.null(fun)) { args <- c(dispatch_args, "...") args <- setNames(lapply(args, function(i) quote(expr = )), args) fun <- new_function(args, quote(S7::S7_dispatch()), parent.frame()) } else { check_generic(fun) } S7_generic(fun, name = name, dispatch_args = 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 (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) } if (!is.null(fun)) { arg_names <- names(formals(fun)) if (!is_prefix(dispatch_args, arg_names)) { stop("`dispatch_args` must be a prefix of the generic arguments", call. = FALSE) } } dispatch_args } #' @export print.S7_generic <- function(x, ...) { methods <- methods(x) formals <- show_args(formals(x), x@name) cat(sprintf(" %s with %i methods:\n", formals, length(methods)), sep = "") if (length(methods) > 0) { signatures <- lapply(methods, prop, "signature") msg <- vcapply(signatures, method_signature, generic = x) msg <- paste0(format(seq_along(signatures)), ": ", msg, "\n") cat(msg, sep = "") } invisible(x) } check_generic <- function(fun) { if (!is.function(fun)) { stop("`fun` must be a function", call. = FALSE) } dispatch_call <- find_call(body(fun), quote(S7_dispatch), packageName()) if (is.null(dispatch_call)) { stop("`fun` must contain a call to `S7_dispatch()`", call. = FALSE) } } #' Recursively find a call (namespaced or plain) #' #' @param x An language object #' @param name A name/symbol #' @param ns A string. If `NULL` (the default), only unnamespaced calls are #' matched. If a string, the call may also match a `ns`-qualified call. #' @return `call` object if found; `NULL` otherwise. #' @noRd find_call <- function(x, name, ns = NULL) { if (!is.call(x)) { return(NULL) } # is namespaced `ns::name(...)` or plain `name(...)` call if (is_ns_call(x[[1]], name, ns) || identical(x[[1]], name)) { return(x) } # otherwise, recurse through arguments if (length(x) > 1) { for (i in seq(2, length(x))) { call <- find_call(x[[i]], name = name, ns = ns) if (!is.null(call)) { return(call) } } } NULL } is_ns_call <- function(x, name, ns = NULL) { if (is.null(ns)) return(FALSE) length(x) == 3 && identical(x[[2]], as.symbol(ns)) && identical(x[[1]], quote(`::`)) && identical(x[[3]], name) } methods <- function(generic) { methods_rec(generic@methods, character()) } methods_rec <- function(x, signature) { if (!is.environment(x)) { return(x) } # Recursively collapse environments to a list methods <- lapply(names(x), function(class) methods_rec(x[[class]], c(signature, class))) unlist(methods, recursive = FALSE) } generic_add_method <- function(generic, signature, method) { p_tbl <- generic@methods chr_signature <- vcapply(signature, class_register) if (is.null(attr(method, "name", TRUE))) attr(method, "name") <- as.name(method_signature(generic, signature)) for (i in seq_along(chr_signature)) { class_name <- chr_signature[[i]] if (i != length(chr_signature)) { # Iterated dispatch, so create another nested environment tbl <- p_tbl[[class_name]] if (is.null(tbl)) { tbl <- new.env(hash = TRUE, parent = emptyenv()) p_tbl[[class_name]] <- tbl } p_tbl <- tbl } else { if (!is.null(p_tbl[[class_name]])) { message("Overwriting method ", method_name(generic, signature)) } p_tbl[[class_name]] <- method } } } S7/R/S4.R0000644000176200001440000001006414712423107011357 0ustar liggesusers#' Register an S7 class with S4 #' #' If you want to use [method<-] to register an method for an S4 generic with #' an S7 class, you need to call `S4_register()` once. #' #' @param class An S7 class created with [new_class()]. #' @param env Expert use only. Environment where S4 class will be registered. #' @returns Nothing; the function is called for its side-effect. #' @export #' @examples #' methods::setGeneric("S4_generic", function(x) { #' standardGeneric("S4_generic") #' }) #' #' Foo <- new_class("Foo") #' S4_register(Foo) #' method(S4_generic, Foo) <- function(x) "Hello" #' #' S4_generic(Foo()) S4_register <- function(class, env = parent.frame()) { if (!is_class(class)) { msg <- sprintf("`class` must be an S7 class, not a %s", obj_desc(class)) } methods::setOldClass(class_dispatch(class), where = topenv(env)) invisible() } is_S4_class <- function(x) inherits(x, "classRepresentation") S4_to_S7_class <- function(x, error_base = "") { # Silence R CMD check false positives distance <- subClass <- className <- package <- NULL # Convert generator function to class if (methods::is(x, "classGeneratorFunction")) { return(S4_to_S7_class(methods::getClass(as.character(x@className)), error_base)) } if (methods::is(x, "ClassUnionRepresentation")) { subclasses <- Filter(function(y) y@distance == 1, x@subclasses) subclasses <- lapply(subclasses, function(x) methods::getClass(x@subClass)) do.call("new_union", subclasses) } else if (methods::is(x, "classRepresentation")) { if (x@package == "methods") { basic_classes <- S4_basic_classes() if (hasName(basic_classes, x@className)) { return(basic_classes[[x@className]]) } } if (methods::extends(x, "oldClass")) { new_S3_class(as.character(x@className)) } else { x } } else { msg <- sprintf( "Unsupported S4 object: must be a class generator or a class definition, not a %s.", obj_desc(x) ) stop(paste0(error_base, msg), call. = FALSE) } } S4_basic_classes <- function() { list( NULL = NULL, logical = class_logical, integer = class_integer, double = class_double, numeric = class_numeric, character = class_character, complex = class_complex, raw = class_raw, list = class_list, expression = class_expression, vector = class_vector, `function` = class_function, environment = class_environment, name = class_name, call = class_call, data.frame = class_data.frame, Date = class_Date, factor = class_factor, POSIXct = class_POSIXct, POSIXlt = class_POSIXlt, POSIXt = class_POSIXt, # matrix = class_matrix, # array = class_array, formula = class_formula ) } S4_class_dispatch <- function(x) { x <- methods::getClass(x) self <- S4_class_name(x) # Find class objects for super classes extends <- unname(methods::extends(x, fullInfo = TRUE)) extends <- Filter(function(x) methods::is(x, "SClassExtension"), extends) classes <- lapply(extends, function(x) methods::getClass(x@superClass)) # Remove unions: S7 handles them in method registration, not dispatch. classes <- Filter(function(x) !methods::is(x, "ClassUnionRepresentation"), classes) # Remove specially named union base classes classes <- Filter(function(x) !x@className %in% c("oldClass", "vector"), classes) c(self, vcapply(classes, S4_class_name)) } is_oldClass <- function(x) { x@virtual && methods::extends(x, "oldClass") && x@className != "oldClass" } S4_class_name <- function(x) { if (is_oldClass(x)) { return(x@className) } class <- x@className package <- x@package %||% attr(class, "package") if (identical(package, "methods") && class %in% names(S4_basic_classes())) { class } else if (is.null(package) || identical(package, ".GlobalEnv")) { paste0("S4/", class) } else { paste0("S4/", package, "::", class) } } S4_remove_classes <- function(classes, where = parent.frame()) { for (class in classes) { suppressWarnings(methods::removeClass(class, topenv(where))) } } globalVariables(c("superClass", "virtual")) S7/R/external-generic.R0000644000176200001440000001162314712423107014327 0ustar liggesusers#' Generics in other packages #' #' @description #' You need an explicit external generic when you want to provide methods #' for a generic (S3, S4, or S7) that is defined in another package, and you #' don't want to take a hard dependency on that package. #' #' The easiest way to provide methods for generics in other packages is #' import the generic into your `NAMESPACE`. This, however, creates a hard #' dependency, and sometimes you want a soft dependency, only registering the #' method if the package is already installed. `new_external_generic()` allows #' you to provide the minimal needed information about a generic so that methods #' can be registered at run time, as needed, using [methods_register()]. #' #' Note that in tests, you'll need to explicitly call the generic from the #' external package with `pkg::generic()`. #' #' @param package Package the generic is defined in. #' @param name Name of generic, as a string. #' @param dispatch_args Character vector giving arguments used for dispatch. #' @param version An optional version the package must meet for the method to #' be registered. #' @returns An S7 external generic, i.e. a list with class #' `S7_external_generic`. #' @export #' @examples #' MyClass <- new_class("MyClass") #' #' your_generic <- new_external_generic("stats", "median", "x") #' method(your_generic, MyClass) <- function(x) "Hi!" new_external_generic <- function(package, name, dispatch_args, version = NULL) { out <- list( package = package, name = name, dispatch_args = dispatch_args, version = version ) class(out) <- "S7_external_generic" out } as_external_generic <- function(x) { if (is_S7_generic(x)) { pkg <- package_name(x) new_external_generic(pkg, x@name, x@dispatch_args) } else if (is_external_generic(x)) { x } else if (is_S3_generic(x)) { pkg <- package_name(x$generic) new_external_generic(pkg, x$name, "__S3__") } else if (is_S4_generic(x)) { new_external_generic(x@package, as.vector(x@generic), x@signature) } } #' @export print.S7_external_generic <- function(x, ...) { cat( " ", x$package, "::", x$name, "(", paste(x$dispatch_args, collapse = ", "), ")", if (!is.null(x$version)) paste0(" (>= ", x$version, ")"), "\n", sep = "" ) invisible(x) } is_external_generic <- function(x) { inherits(x, "S7_external_generic") } #' Register methods in a package #' #' When using S7 in a package you should always call `methods_register()` when #' your package is loaded. This ensures that methods are registered as needed #' when you implement methods for generics (S3, S4, and S7) in other packages. #' (This is not strictly necessary if you only register methods for generics #' in your package, but it's better to include it and not need it than forget #' to include it and hit weird errors.) #' #' @importFrom utils getFromNamespace packageName #' @export #' @returns Nothing; called for its side-effects. #' @examples #' .onLoad <- function(...) { #' S7::methods_register() #' } methods_register <- function() { package <- packageName(parent.frame()) ns <- topenv(parent.frame()) # TODO?: check/enforce that methods_register() is being called from .onLoad() tbl <- S7_methods_table(package) for (x in tbl) { register <- registrar(x$generic, x$signature, x$method, ns) if (isNamespaceLoaded(x$generic$package)) { register() } else { setHook(packageEvent(x$generic$package, "onLoad"), register) } } invisible() } registrar <- function(generic, signature, method, env) { # Force all arguments generic; signature; method; env; function(...) { ns <- asNamespace(generic$package) if (is.null(generic$version) || getNamespaceVersion(ns) >= generic$version) { if (!exists(generic$name, envir = ns, inherits = FALSE)) { msg <- sprintf("[S7] Failed to find generic %s() in package %s", generic$name, generic$package) warning(msg, call. = FALSE) } else { generic_fun <- get(generic$name, envir = ns, inherits = FALSE) register_method(generic_fun, signature, method, env, package = NULL) } } } } external_methods_reset <- function(package) { S7_methods_table(package) <- list() invisible() } external_methods_add <- function(package, generic, signature, method) { tbl <- S7_methods_table(package) append1(tbl) <- list(generic = generic, signature = signature, method = method) S7_methods_table(package) <- tbl invisible() } # Store external methods in an attribute of the S3 methods table since # this mutable object is present in all packages. S7_methods_table <- function(package) { ns <- asNamespace(package) tbl <- ns[[".__S3MethodsTable__."]] attr(tbl, "S7methods") %||% list() } `S7_methods_table<-` <- function(package, value) { ns <- asNamespace(package) tbl <- ns[[".__S3MethodsTable__."]] attr(tbl, "S7methods") <- value invisible() } S7/R/valid.R0000644000176200001440000001056414703771245012206 0ustar liggesusers#' Validate an S7 object #' #' @description #' `validate()` ensures that an S7 object is valid by calling the `validator` #' provided in [new_class()]. This is done automatically when constructing new #' objects and when modifying properties. #' #' `valid_eventually()` disables validation, modifies the object, then #' revalidates. This is useful when a sequence of operations would otherwise #' lead an object to be temporarily invalid, or when repeated property #' modification causes a performance bottleneck because the validator is #' relatively expensive. #' #' `valid_implicitly()` does the same but does not validate the object at the #' end. It should only be used rarely, and in performance critical code where #' you are certain a sequence of operations cannot produce an invalid object. #' @param object An S7 object #' @param fun A function to call on the object before validation. #' @param recursive If `TRUE`, calls validator of parent classes recursively. #' @param properties If `TRUE`, the default, checks property types before #' executing the validator. #' @returns Either `object` invisibly if valid, otherwise an error. #' @export #' @examples #' # A range class might validate that the start is less than the end #' Range <- new_class("Range", #' properties = list(start = class_double, end = class_double), #' validator = function(self) { #' if (self@start >= self@end) "start must be smaller than end" #' } #' ) #' # You can't construct an invalid object: #' try(Range(1, 1)) #' #' # And you can't create an invalid object with @<- #' r <- Range(1, 2) #' try(r@end <- 1) #' #' # But what if you want to move a range to the right? #' rightwards <- function(r, x) { #' r@start <- r@start + x #' r@end <- r@end + x #' r #' } #' # This function doesn't work because it creates a temporarily invalid state #' try(rightwards(r, 10)) #' #' # This is the perfect use case for valid_eventually(): #' rightwards <- function(r, x) { #' valid_eventually(r, function(object) { #' object@start <- object@start + x #' object@end <- object@end + x #' object #' }) #' } #' rightwards(r, 10) #' #' # Alternatively, you can set multiple properties at once using props<-, #' # which validates once at the end #' rightwards <- function(r, x) { #' props(r) <- list(start = r@start + x, end = r@end + x) #' r #' } #' rightwards(r, 20) validate <- function(object, recursive = TRUE, properties = TRUE) { check_is_S7(object) if (!is.null(attr(object, ".should_validate"))) { return(invisible(object)) } class <- S7_class(object) # First, check property types - if these are incorrect, the validator # is likely to return spurious errors if (properties) { errors <- validate_properties(object, class) if (length(errors) > 0) { bullets <- paste0("- ", errors, collapse = "\n") msg <- sprintf("%s object properties are invalid:\n%s", obj_desc(object), bullets) stop(msg, call. = FALSE) } } # Next, recursively validate the object errors <- character() repeat { error <- class_validate(class, object) if (is.null(error)) { } else if (is.character(error)) { append(errors) <- error } else { stop(sprintf( "%s validator must return NULL or a character, not <%s>.", obj_desc(class), typeof(error) )) } if (!is_class(class) || !recursive) break class <- class@parent } # If needed, report errors if (length(errors) > 0) { bullets <- paste0("- ", errors, collapse = "\n") msg <- sprintf("%s object is invalid:\n%s", obj_desc(object), bullets) stop(msg, call. = FALSE) } invisible(object) } validate_properties <- function(object, class) { errors <- character() for (prop_obj in class@properties) { # Don't validate dynamic properties if (!is.null(prop_obj$getter)) { next } value <- prop(object, prop_obj$name) errors <- c(errors, prop_validate(prop_obj, value)) } errors } #' @rdname validate #' @export valid_eventually <- function(object, fun) { old <- attr(object, ".should_validate") attr(object, ".should_validate") <- FALSE out <- fun(object) attr(out, ".should_validate") <- old validate(out) out } #' @rdname validate #' @export valid_implicitly <- function(object, fun) { old <- attr(object, ".should_validate") attr(object, ".should_validate") <- FALSE out <- fun(object) attr(out, ".should_validate") <- old out } S7/R/method-register.R0000644000176200001440000002207714712423107014202 0ustar liggesusers#' Register an S7 method for a generic #' #' @description #' A generic defines the interface of a function. Once you have created a #' generic with [new_generic()], you provide implementations for specific #' signatures by registering methods with `method<-`. #' #' The goal is for `method<-` to be the single function you need when working #' with S7 generics or S7 classes. This means that as well as registering #' methods for S7 classes on S7 generics, you can also register methods for #' S7 classes on S3 or S4 generics, and S3 or S4 classes on S7 generics. #' But this is not a general method registration function: at least one of #' `generic` and `signature` needs to be from S7. #' #' Note that if you are writing a package, you must call [methods_register()] #' in your `.onLoad`. This ensures that all methods are dynamically registered #' when needed. #' #' @param generic A generic function, i.e. an [S7 generic][new_generic], #' an [external generic][new_external_generic], an [S3 generic][UseMethod], #' or an [S4 generic][methods::setGeneric]. #' @param signature A method signature. #' #' For S7 generics that use single dispatch, this must be one of the #' following: #' #' * An S7 class (created by [new_class()]). #' * An S7 union (created by [new_union()]). #' * An S3 class (created by [new_S3_class()]). #' * An S4 class (created by [methods::getClass()] or [methods::new()]). #' * A base type like [class_logical], [class_integer], or [class_numeric]. #' * A special type like [class_missing] or [class_any]. #' #' For S7 generics that use multiple dispatch, this must be a list of any of #' the above types. #' #' For S3 generics, this must be a single S7 class. #' #' For S4 generics, this must either be an S7 class, or a list that includes #' at least one S7 class. #' @param value A function that implements the generic specification for the #' given `signature`. #' @returns The `generic`, invisibly. #' @export #' @examples #' # Create a generic #' bizarro <- new_generic("bizarro", "x") #' # Register some methods #' method(bizarro, class_numeric) <- function(x) rev(x) #' method(bizarro, new_S3_class("data.frame")) <- function(x) { #' x[] <- lapply(x, bizarro) #' rev(x) #' } #' #' # Using a generic calls the methods automatically #' bizarro(head(mtcars)) `method<-` <- function(generic, signature, value) { register_method(generic, signature, value, env = parent.frame()) invisible(generic) } register_method <- function(generic, signature, method, env = parent.frame(), package = packageName(env)) { generic <- as_generic(generic) signature <- as_signature(signature, generic) if (is_external_generic(generic) && isNamespaceLoaded(generic$package)) { generic <- as_generic(getFromNamespace(generic$name, generic$package)) } # Register in current session if (is_S7_generic(generic)) { check_method(method, generic, name = method_name(generic, signature)) register_S7_method(generic, signature, method) } else if (is_S3_generic(generic)) { register_S3_method(generic, signature, method, env) } else if (is_S4_generic(generic)) { register_S4_method(generic, signature, method, env) } # if we're inside a package, we also need to be able register methods # when the package is loaded if (!is.null(package) && !is_local_generic(generic, package)) { generic <- as_external_generic(generic) external_methods_add(package, generic, signature, method) } invisible(generic) } register_S3_method <- function(generic, signature, method, envir = parent.frame()) { if (class_type(signature[[1]]) != "S7") { msg <- sprintf( "When registering methods for S3 generic %s(), signature must be an S7 class, not %s.", generic$name, class_friendly(signature[[1]]) ) stop(msg, call. = FALSE) } if (is_external_generic(external_generic <- get0(generic$name, envir = envir))) { envir <- asNamespace(external_generic$package) } class <- S7_class_name(signature[[1]]) registerS3method(generic$name, class, method, envir) } register_S7_method <- function(generic, signature, method) { # Flatten out unions to individual signatures signatures <- flatten_signature(signature) # Register each method for (signature in signatures) { method <- S7_method(method, generic = generic, signature = signature) generic_add_method(generic, signature, method) } invisible() } flatten_signature <- function(signature) { # Unpack unions sig_is_union <- vlapply(signature, is_union) signature[sig_is_union] <- lapply(signature[sig_is_union], "[[", "classes") signature[!sig_is_union] <- lapply(signature[!sig_is_union], list) # Create grid of indices indx <- lapply(signature, seq_along) comb <- as.matrix(rev(do.call("expand.grid", rev(indx)))) colnames(comb) <- NULL rows <- lapply(1:nrow(comb), function(i) comb[i, ]) lapply(rows, function(row) Map("[[", signature, row)) } as_signature <- function(signature, generic) { if (inherits(signature, "S7_signature")) { return(signature) } n <- generic_n_dispatch(generic) if (n == 1) { new_signature(list(as_class(signature, arg = "signature"))) } else { check_signature_list(signature, n) for (i in seq_along(signature)) { signature[i] <- list(as_class(signature[[i]], arg = sprintf("signature[[%i]]", i))) } new_signature(signature) } } check_signature_list <- function(x, n, arg = "signature") { if (!is.list(x) || is.object(x)) { stop(sprintf("`%s` must be a list for multidispatch generics", arg), call. = FALSE) } if (length(x) != n) { stop(sprintf("`%s` must be length %i", arg, n), call. = FALSE) } } new_signature <- function(x) { class(x) <- "S7_signature" x } check_method <- function(method, generic, name = paste0(generic@name, "(???)")) { if (!is.function(method)) { stop(sprintf("%s must be a function", name), call. = FALSE) } generic_formals <- formals(args(generic)) method_formals <- formals(method) generic_args <- names(generic_formals) method_args <- names(method_formals) if (!"..." %in% generic_args && !identical(generic_formals, method_formals)) { msg <- sprintf( "%s() generic lacks `...` so method formals must match generic formals exactly.", generic@name ) bullets <- c( sprintf("- generic formals: %s", show_args(generic_formals, name = generic@name)), sprintf("- method formals: %s", show_args(method_formals, name = generic@name)) ) msg <- paste0(c(msg, bullets), collapse = "\n") stop(msg, call. = FALSE) } 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) { msg <- sprintf( "%s() dispatches on %s, but %s has arguments %s", generic@name, arg_names(generic@dispatch_args), name, arg_names(method_args) ) stop(msg, call. = FALSE) } empty_dispatch <- vlapply(method_formals[generic@dispatch_args], identical, quote(expr = )) if (any(!empty_dispatch)) { msg <- sprintf( "In %s, dispatch arguments (%s) must not have default values", name, arg_names(generic@dispatch_args) ) stop(msg, call. = FALSE) } extra_args <- setdiff(names(generic_formals), c(generic@dispatch_args, "...")) for (arg in extra_args) { if (!arg %in% method_args) { warning(sprintf("%s doesn't have argument `%s`", name, arg), call. = FALSE) } else if (!identical(generic_formals[[arg]], method_formals[[arg]])) { msg <- sprintf( paste0( "In %s, default value of `%s` is not the same as the generic\n", "- Generic: %s\n", "- Method: %s" ), name, arg, deparse1(generic_formals[[arg]]), deparse1(method_formals[[arg]]) ) warning(msg, call. = FALSE) } } invisible(TRUE) } register_S4_method <- function(generic, signature, method, env = parent.frame()) { S4_env <- topenv(env) S4_signature <- lapply(signature, S4_class, S4_env = S4_env) methods::setMethod(generic, S4_signature, method, where = S4_env) } S4_class <- function(x, S4_env) { if (is_base_class(x)) { x@name } else if (is_S4_class(x)) { x } else if (is_class(x) || is_S3_class(x)) { class <- tryCatch(methods::getClass(class_register(x)), error = function(err) NULL) if (is.null(class)) { msg <- sprintf( "Class has not been registered with S4; please call S4_register(%s)", class_deparse(x) ) stop(msg, call. = FALSE) } class } else { stop("Unsupported") } } #' @export print.S7_method <- function(x, ...) { signature <- method_signature(x@generic, x@signature) cat(" ", signature, "\n", sep = "") attributes(x) <- NULL print(x) } arg_names <- function(x) { paste0(encodeString(x, quote = "`"), collapse = ", ") } method_name <- function(generic, signature) { method_args <- paste0(vcapply(signature, class_desc), collapse =", ") sprintf("%s(%s)", generic@name, method_args) } S7/R/utils.R0000644000176200001440000001073614712423107012237 0ustar liggesusersglobal_variables <- function(names) { env <- topenv(parent.frame()) if (exists(".__global__", envir = env) && bindingIsLocked(".__global__", env = env)) { get("unlockBinding", baseenv())(".__global__", env = env) on.exit(lockBinding(".__global__", env = env)) } current <- get0(".__global__", envir = env, ifnotfound = character()) current <- unique(c(current, names)) assign(".__global__", current, envir = env) } vlapply <- function(X, FUN, ...) vapply(X = X, FUN = FUN, FUN.VALUE = logical(1), ...) vcapply <- function(X, FUN, ...) vapply(X = X, FUN = FUN, FUN.VALUE = character(1), ...) method_signature <- function(generic, signature) { single <- length(generic@dispatch_args) == 1 if (single) { signature <- class_deparse(signature[[1]]) } else { classes <- vcapply(signature, class_deparse) signature <- paste0("list(", paste0(classes, collapse = ", "), ")") } sprintf("method(%s, %s)", generic@name, signature) } names2 <- function(x) { nms <- names(x) if (is.null(nms)) { rep("", length(x)) } else { nms } } is_prefix <- function(x, y) { length(x) <= length(y) && identical(unclass(x), unclass(y)[seq_along(x)]) } oxford_or <- function (x) { n <- length(x) if (n == 1) { x } else if (n == 2) { paste0(x[[1]], " or ", x[[2]]) } else if (n >= 2) { x <- c(x[seq(1, n - 2, by = 1)], paste0(x[[n - 1]], ", or ", x[[n]])) paste0(x, collapse = ", ") } } str_nest <- function( object, prefix, ..., nest.lev = 0, indent.str = paste(rep.int(" ", max(0, nest.lev + 1)), collapse = "..") ) { names <- format(names(object)) for (i in seq_along(object)) { cat(indent.str, prefix, " ", names[[i]], ":", sep = "") xi <- object[[i]] if (is.function(xi)) { str_function(xi, nest.lev = nest.lev + 1) } else { str(xi, ..., nest.lev = nest.lev + 1) } } } str_function <- function(object, ..., nest.lev = 0) { attr(object, "srcref") <- NULL if (identical(class(object), "function")) { cat(" ") } str(object, ..., nest.lev = nest.lev) } check_name <- function(name, arg = deparse(substitute(name))) { if (length(name) != 1 || !is.character(name)) { msg <- sprintf("`%s` must be a single string", arg) stop(msg, call. = FALSE) } if (is.na(name) || name == "") { msg <- sprintf("`%s` must not be \"\" or NA", arg) stop(msg, call. = FALSE) } } check_function <- function(f, args, arg = deparse(substitute(f))) { if (!is.function(f)) { msg <- sprintf("`%s` must be a function", arg) stop(msg, call. = FALSE) } args <- as.pairlist(args) if (!identical(formals(f), args)) { msg <- sprintf( "`%s` must be %s, not %s", arg, show_args(args), show_args(formals(f)) ) stop(msg, call. = FALSE) } } show_function <- function(x, constructor = FALSE) { args <- formals(x) if (constructor) { # don't show the defaults arg values in the constructor, keep it compact # TODO: do show the default values next to properties in class printouts. args <- lapply(args, function(q) quote(expr =)) } show_args(args, suffix = " {...}") } show_args <- function(x, name = "function", suffix = "") { if (length(x) == 0) { args <- "" } else { val <- vcapply(x, deparse1) args <- paste0(names(x), ifelse(val == "", "", " = "), val, collapse = ", ") } paste0(name, "(", args, ")", suffix) } modify_list <- function (x, new_vals) { stopifnot(is.list(x) || is.pairlist(x), all(nzchar(names2(x)))) if (length(new_vals)) { nms <- names2(new_vals) if (!all(nzchar(nms))) stop("all elements in `new_vals` must be named") if (is.null(x)) x <- list() x[nms] <- new_vals } x } deparse_trunc <- function(x, width, collapse = "\n") { x <- deparse1(x, collapse) if (nchar(x) > width) x <- sprintf("%s....", substr(x, 0, width-4)) x } # For older versions of R ---------------------------------------------------- deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) { paste(deparse(expr, width.cutoff, ...), collapse = collapse) } list2DF <- function(x = list(), nrow = 0L) { stopifnot(is.list(x), is.null(nrow) || nrow >= 0L) if (n <- length(x)) { if (length(nrow <- unique(lengths(x))) > 1L) { stop("all variables should have the same length") } } else { if (is.null(nrow)) { nrow <- 0L } } if (is.null(names(x))) { names(x) <- character(n) } class(x) <- "data.frame" attr(x, "row.names") <- .set_row_names(nrow) x } S7/R/base.R0000644000176200001440000001071014712423107012001 0ustar liggesusersnew_base_class <- function(name, constructor_name = name) { force(name) constructor <- new_function( args = list(.data = base_default(name)), body = quote(.data), env = baseenv() ) validator <- function(object) { if (base_class(object) != name) { sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) } } validator <- utils::removeSource(validator) out <- list( class = name, constructor_name = constructor_name, constructor = constructor, validator = validator ) class(out) <- "S7_base_class" out } #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass,S7_base_class) nameOfClass.S7_base_class <- function(x) { x[["class"]] } base_default <- function(type) { switch(type, logical = logical(), integer = integer(), double = double(), complex = complex(), character = character(), raw = raw(), list = list(), expression = expression(), name = quote(quote(x)), call = quote(quote({})), `function` = quote(function() NULL), environment = quote(new.env(parent = emptyenv())) )} is_base_class <- function(x) inherits(x, "S7_base_class") #' @export print.S7_base_class <- function(x, ...) { cat(": ", class_desc(x), "\n", sep = "") invisible(x) } #' @export str.S7_base_class <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") print(object, ..., nest.lev = nest.lev) } #' S7 wrappers for base types #' #' @description #' The following S7 classes represent base types allowing them to be used #' within S7: #' #' * `class_logical` #' * `class_integer` #' * `class_double` #' * `class_complex` #' * `class_character` #' * `class_raw` #' * `class_list` #' * `class_expression` #' * `class_name` #' * `class_call` #' * `class_function` #' * `class_environment` (can only be used for properties) #' #' We also include three union types to model numerics, atomics, and vectors #' respectively: #' #' * `class_numeric` is a union of `class_integer` and `class_double`. #' * `class_atomic` is a union of `class_logical`, `class_numeric`, #' `class_complex`, `class_character`, and `class_raw`. #' * `class_vector` is a union of `class_atomic`, `class_list`, and #' `class_expression`. #' * `class_language` is a union of `class_name` and `class_call`. #' #' @order 0 #' @name base_classes #' @return S7 classes wrapping around common base types and S3 classes. #' @examples #' #' class_integer #' class_numeric #' class_factor NULL #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_logical <- new_base_class("logical") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_integer <- new_base_class("integer") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_double <- new_base_class("double") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_complex <- new_base_class("complex") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_character <- new_base_class("character") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_raw <- new_base_class("raw") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_list <- new_base_class("list") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_expression <- new_base_class("expression") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_name <- new_base_class("name") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_call <- new_base_class("call") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_function <- new_base_class("function", "fun") #' @export #' @rdname base_classes #' @format NULL #' @order 1 class_environment <- new_base_class("environment") #' @export #' @rdname base_classes #' @format NULL #' @order 2 class_numeric <- NULL #' @export #' @rdname base_classes #' @format NULL #' @order 2 class_atomic <- NULL #' @export #' @rdname base_classes #' @format NULL #' @order 2 class_vector <- NULL #' @export #' @rdname base_classes #' @format NULL #' @order 2 class_language <- NULL # Define onload to avoid dependencies between files on_load_define_union_classes <- function() { class_numeric <<- new_union(class_integer, class_double) class_atomic <<- new_union(class_logical, class_numeric, class_complex, class_character, class_raw) class_vector <<- new_union(class_atomic, class_expression, class_list) class_language <<- new_union(class_name, class_call) } S7/R/method-dispatch.R0000644000176200001440000000136314712423107014150 0ustar liggesusers# Called from C method_lookup_error <- function(name, args) { types <- vcapply(args, obj_desc) msg <- method_lookup_error_message(name, types) cnd <- errorCondition(msg, class = c("S7_error_method_not_found", "error")) stop(cnd) } method_lookup_error_message <- function(name, types) { if (length(types) == 1) { sprintf("Can't find method for `%s(%s)`.", name, types) } else { arg_names <- paste0(names(types), collapse = ", ") types <- paste0("- ", format(names(types)), ": ", types, collapse = "\n") sprintf("Can't find method for generic `%s(%s)`:\n%s", name, arg_names, types) } } #' @rdname new_generic #' @order 2 #' @export S7_dispatch <- function() { .External2(method_call_, sys.function(-1L), sys.frame(-1L)) } S7/R/constructor.R0000644000176200001440000000726114712423107013463 0ustar liggesusersnew_constructor <- function(parent, properties, envir = asNamespace("S7"), package = NULL) { properties <- as_properties(properties) arg_info <- constructor_args(parent, properties, envir, package) self_args <- as_names(names(arg_info$self), named = TRUE) if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) { new_object_call <- if (has_S7_symbols(envir, "new_object", "S7_object")) { bquote(new_object(S7_object(), ..(self_args)), splice = TRUE) } else { bquote(S7::new_object(S7::S7_object(), ..(self_args)), splice = TRUE) } return(new_function( args = arg_info$self, body = as.call(c(quote(`{`), # Force all promises here so that any errors are signaled from # the constructor() call instead of the new_object() call. unname(self_args), new_object_call )), env = envir )) } if (is_class(parent)) { parent_name <- parent@name parent_fun <- parent args <- modify_list(arg_info$parent, arg_info$self) } else if (is_base_class(parent)) { parent_name <- parent$constructor_name parent_fun <- parent$constructor args <- modify_list(arg_info$parent, arg_info$self) } else if (is_S3_class(parent)) { parent_name <- paste0("new_", parent$class[[1]]) parent_fun <- parent$constructor args <- formals(parent$constructor) args[names(arg_info$self)] <- arg_info$self } else { # user facing error in S7_class() stop("Unsupported `parent` type", call. = FALSE) } # ensure default value for `...` is empty if ("..." %in% names(args)) { args[names(args) == "..."] <- list(quote(expr = )) } parent_args <- as_names(names(arg_info$parent), named = TRUE) names(parent_args)[names(parent_args) == "..."] <- "" parent_call <- new_call(parent_name, parent_args) body <- new_call( if (has_S7_symbols(envir, "new_object")) "new_object" else c("S7", "new_object"), c(parent_call, self_args) ) env <- new.env(parent = envir) env[[parent_name]] <- parent_fun new_function(args, body, env) } constructor_args <- function(parent, properties = list(), envir = asNamespace("S7"), package = NULL) { parent_args <- formals(class_constructor(parent)) # Remove read-only properties properties <- properties[!vlapply(properties, prop_is_read_only)] self_arg_nms <- names2(properties) if (is_class(parent) && !parent@abstract) { # Remove any parent properties; can't use parent_args() since the constructor # might automatically set some properties. self_arg_nms <- setdiff(self_arg_nms, names2(parent@properties)) } self_args <- as.pairlist(lapply( setNames(, self_arg_nms), function(name) prop_default(properties[[name]], envir, package)) ) list(parent = parent_args, self = self_args) } # helpers ----------------------------------------------------------------- is_property_dynamic <- function(x) is.function(x$getter) missing_args <- function(names) { lapply(setNames(, names), function(i) quote(class_missing)) } new_call <- function(call, args) { if (is.character(call)) { call <- switch(length(call), as.name(call), as.call(c(quote(`::`), lapply(call, as.name)))) } as.call(c(list(call), args)) } as_names <- function(x, named = FALSE) { if (named) { names(x) <- x } lapply(x, as.name) } has_S7_symbols <- function(env, ...) { env <- topenv(env) if (identical(env, asNamespace("S7"))) return (TRUE) if (!isNamespace(env)) return (FALSE) imports <- getNamespaceImports(env)[["S7"]] symbols <- c(...) %||% getNamespaceExports("S7") all(symbols %in% imports) } S7/R/data.R0000644000176200001440000000205114712423107011777 0ustar liggesusers#' Get/set underlying "base" data #' #' When an S7 class inherits from an existing base type, it can be useful #' to work with the underlying object, i.e. the S7 object stripped of class #' and properties. #' #' @inheritParams prop #' @param value Object used to replace the underlying data. #' @return `S7_data()` returns the data stored in the base object; #' `S7_data<-()` is called for its side-effects and returns `object` #' invisibly. #' @export #' @examples #' Text <- new_class("Text", parent = class_character) #' y <- Text(c(foo = "bar")) #' y #' S7_data(y) #' #' S7_data(y) <- c("a", "b") #' y S7_data <- function(object) { check_is_S7(object) zap_attr(object, c(prop_names(object), "class", "S7_class")) } #' @export #' @rdname S7_data `S7_data<-` <- function(object, check = TRUE, value) { attrs <- attributes(object) object <- value attributes(object) <- attrs if (isTRUE(check)) { validate(object) } return(invisible(object)) } zap_attr <- function(x, names) { for (name in names) { attr(x, name) <- NULL } x } S7/R/method-introspect.R0000644000176200001440000001126014712423107014540 0ustar liggesusers#' Find a method for an S7 generic #' #' `method()` takes a generic and class signature and performs method dispatch #' to find the corresponding method implementation. This is rarely needed #' because you'll usually rely on the the generic to do dispatch for you (via #' [S7_dispatch()]). However, this introspection is useful if you want to see #' the implementation of a specific method. #' #' @seealso [method_explain()] to explain why a specific method was picked. #' @inheritParams method<- #' @returns Either a function with class `S7_method` or an error if no #' matching method is found. #' @param class,object Perform introspection either with a `class` #' (processed with [as_class()]) or a concrete `object`. If `generic` uses #' multiple dispatch then both `object` and `class` must be a list of #' classes/objects. #' @export #' @examples #' # Create a generic and register some methods #' bizarro <- new_generic("bizarro", "x") #' method(bizarro, class_numeric) <- function(x) rev(x) #' method(bizarro, class_factor) <- function(x) { #' levels(x) <- rev(levels(x)) #' x #' } #' #' # Printing the generic shows the registered method #' bizarro #' #' # And you can use method() to inspect specific implementations #' method(bizarro, class = class_integer) #' method(bizarro, object = 1) #' method(bizarro, class = class_factor) #' #' # errors if method not found #' try(method(bizarro, class = class_data.frame)) #' try(method(bizarro, object = "x")) method <- function(generic, class = NULL, object = NULL) { check_is_S7(generic, S7_generic) dispatch <- as_dispatch(generic, class = class, object = object) method <- .Call(method_, generic, dispatch, environment(), FALSE) if (!is.null(method)) { return(method) } # can't rely on usual error mechanism because it involves looking up # argument values in the dispatch environment, which doesn't exist here types <- error_types(generic, class = class, object = object) msg <- method_lookup_error_message(generic@name, types) stop(msg, call. = FALSE) } #' Explain method dispatch #' #' @description #' `method_explain()` shows all possible methods that a call to a generic #' might use, which ones exist, and which one will actually be called. #' #' Note that method dispatch uses a string representation of each class in #' the class hierarchy. Each class system uses a slightly different convention #' to avoid ambiguity. #' #' * S7: `pkg::class` or `class` #' * S4: `S4/pkg::class` or `S4/class` #' * S3: `class` #' #' @inheritParams method #' @return Nothing; this function is called for it's side effects. #' @export #' @examples #' Foo1 <- new_class("Foo1") #' Foo2 <- new_class("Foo2", Foo1) #' #' add <- new_generic("add", c("x", "y")) #' method(add, list(Foo2, Foo1)) <- function(x, y) c(2, 1) #' method(add, list(Foo1, Foo1)) <- function(x, y) c(1, 1) #' #' method_explain(add, list(Foo2, Foo2)) method_explain <- function(generic, class = NULL, object = NULL) { check_is_S7(generic, S7_generic) dispatch <- as_dispatch(generic, class = class, object = object) dispatch <- lapply(dispatch, c, "ANY") grid <- as.matrix(rev(do.call("expand.grid", rev(dispatch)))) colnames(grid) <- generic@dispatch_args names <- paste0("[", grid, "]") dim(names) <- dim(grid) methods <- apply(names, 1, paste, collapse = ", ") has_method <- function(dispatches, env) { for (x in dispatches) { env <- env[[x]] } is.function(env) } exists <- apply(grid, 1, has_method, env = generic@methods) label <- ifelse(exists, "* ", " ") if (any(exists)) { label[which(exists)[[1]]] <- "->" } cat(paste0(label, " ", generic@name, "(", methods, ")\n"), sep = "") invisible() } as_dispatch <- function(generic, class = NULL, object = NULL) { if (!is.null(class) && is.null(object)) { signature <- as_signature(class, generic) is_union <- vlapply(signature, is_union) if (any(is_union)) { stop("Can't dispatch on unions; must be a concrete type") } lapply(signature, class_dispatch) } else if (!is.null(object) && is.null(class)) { n <- generic_n_dispatch(generic) if (n == 1) { object <- list(object) } else { check_signature_list(object, n = n, arg = "object") } lapply(object, obj_dispatch) } else { stop("Must supply exactly one of `class` and `object`", call. = FALSE) } } error_types <- function(generic, class = NULL, object = NULL) { if (is.null(class)) { n <- generic_n_dispatch(generic) if (n == 1) { types <- list(obj_desc(object)) } else { types <- vcapply(object, obj_desc) } } else { signature <- as_signature(class, generic) types <- vcapply(signature, class_desc) } names(types) <- generic@dispatch_args types } S7/R/inherits.R0000644000176200001440000000306014712702212012711 0ustar liggesusers#' Does this object inherit from an S7 class? #' #' * `S7_inherits()` returns `TRUE` or `FALSE`. #' * `check_is_S7()` throws an error if `x` isn't the specified `class`. #' #' @param x An object #' @param class An S7 class or `NULL`. If `NULL`, tests whether `x` is an #' S7 object without testing for a specific class. #' @param arg Argument name used in error message. #' @returns #' * `S7_inherits()` returns a single `TRUE` or `FALSE`. #' * `check_is_S7()` returns nothing; it's called for its side-effects. #' #' @note Starting with \R 4.3.0, `base::inherits()` can accept an S7 class as #' the second argument, supporting usage like `inherits(x, Foo)`. #' @export #' @examples #' Foo1 <- new_class("Foo1") #' Foo2 <- new_class("Foo2") #' #' S7_inherits(Foo1(), Foo1) #' check_is_S7(Foo1()) #' check_is_S7(Foo1(), Foo1) #' #' S7_inherits(Foo1(), Foo2) #' try(check_is_S7(Foo1(), Foo2)) #' #' if (getRversion() >= "4.3.0") #' inherits(Foo1(), Foo1) S7_inherits <- function(x, class = NULL) { if (!(is.null(class) || inherits(class, "S7_class"))) { stop("`class` must be an or NULL") } inherits(x, "S7_object") && (is.null(class) || inherits(x, S7_class_name(class))) } #' @export #' @rdname S7_inherits # called from src/prop.c check_is_S7 <- function(x, class = NULL, arg = deparse(substitute(x))) { if (S7_inherits(x, class)) { return(invisible()) } msg <- sprintf( "`%s` must be %s, not a %s", arg, if (is.null(class)) "an " else paste0("a ", class_desc(class)), obj_desc(x) ) stop(msg, call. = FALSE) } S7/R/generic-spec.R0000644000176200001440000000562214712423107013441 0ustar liggesusersis_generic <- function(x) { is_S7_generic(x) || is_external_generic(x) || is_S3_generic(x) || is_S4_generic(x) } as_generic <- function(x) { if (is_generic(x)) { x } else if (is.function(x)) { as_S3_generic(x) } else { msg <- sprintf("`generic` must be a function, not a %s", obj_desc(x)) stop(msg, call. = FALSE) } } as_S3_generic <- function(x) { use_method <- find_call(body(x), quote(UseMethod)) if (!is.null(use_method)) { return(S3_generic(x, as.character(use_method[[2]]))) } else { name <- find_base_name(x) if (name %in% names(base_ops)) { return(base_ops[[name]]) } else if (name %in% names(base_matrix_ops)) { return(base_matrix_ops[[name]]) } else if (!is.na(name) && is_internal_generic(name)) { return(S3_generic(x, name)) } } stop("`generic` is a function, but not an S3 generic function: \n", deparse_trunc(x, 100), call. = FALSE) } S3_generic <- function(generic, name) { out <- list(generic = generic, name = name) class(out) <- "S7_S3_generic" out } is_S3_generic <- function(x) inherits(x, "S7_S3_generic") is_S4_generic <- function(x) inherits(x, "genericFunction") # Is the generic defined in the "current" package is_local_generic <- function(generic, package) { if (is_external_generic(generic)) { return(FALSE) } generic_pkg <- package_name(generic) is.null(generic_pkg) || generic_pkg == package } package_name <- function(f) { env <- environment(f) if (is.null(env)) { "base" } else { (packageName(env)) } } generic_n_dispatch <- function(x) { if (is_S7_generic(x)) { length(x@dispatch_args) } else if (is_external_generic(x)) { length(x$dispatch_args) } else if (is_S3_generic(x)) { 1 } else if (is_S4_generic(x)) { length(x@signature) } else { stop(sprintf("Invalid input %", obj_desc(x)), call. = FALSE) } } # Internal generics ------------------------------------------------------- find_base_name <- function(f, candidates = NULL) { env <- baseenv() candidates <- candidates %||% names(env) for (name in candidates) { if (identical(f, env[[name]])) { return(name) } } NA } is_internal_generic <- function(x) { x %in% internal_generics() } internal_generics <- function() { group <- unlist(group_generics(), use.names = FALSE) primitive <- .S3PrimitiveGenerics # Extracted from ?"internal generic" internal <- c("[", "[[", "$", "[<-", "[[<-", "$<-", "unlist", "cbind", "rbind", "as.vector") c(group, primitive, internal) } group_generics <- function() { # S3 group generics can be defined by combining S4 group generics groups <- list( Ops = c("Arith", "Compare", "Logic"), Math = c("Math", "Math2"), Summary = "Summary", Complex = "Complex" ) out <- lapply(groups, function(x) unlist(lapply(x, methods::getGroupMembers))) if (getRversion() >= "4.3") { out$matrixOps <- c("%*%") } out } S7/R/property.R0000644000176200001440000003465314712423107012767 0ustar liggesusers#' Define a new property #' #' @description #' A property defines a named component of an object. Properties are #' typically used to store (meta) data about an object, and are often #' limited to a data of a specific `class`. #' #' By specifying a `getter` and/or `setter`, you can make the property #' "dynamic" so that it's computed when accessed or has some non-standard #' behaviour when modified. Dynamic properties are not included as an argument #' to the default class constructor. #' #' See the "Properties: Common Patterns" section in `vignette("class-objects")` #' for more examples. #' #' @param class Class that the property must be an instance of. #' See [as_class()] for details. #' @param getter An optional function used to get the value. The function #' should take `self` as its sole argument and return the value. If you #' supply a `getter`, you are responsible for ensuring that it returns #' an object of the correct `class`; it will not be validated automatically. #' #' If a property has a getter but doesn't have a setter, it is read only. #' @param setter An optional function used to set the value. The function #' should take `self` and `value` and return a modified object. #' @param validator A function taking a single argument, `value`, the value #' to validate. #' #' The job of a validator is to determine whether the property value is valid. #' It should return `NULL` if the object is valid, or if it's not valid, #' a single string describing the problem. The message should not include the #' name of the property as this will be automatically appended to the #' beginning of the message. #' #' The validator will be called after the `class` has been verified, so #' your code can assume that `value` has known type. #' @param default When an object is created and the property is not supplied, #' what should it default to? If `NULL`, it defaults to the "empty" instance #' of `class`. This can also be a quoted call, which then becomes a standard #' function promise in the default constructor, evaluated at the time the #' object is constructed. #' @param name Property name, primarily used for error messages. Generally #' don't need to set this here, as it's more convenient to supply as a #' the element name when defining a list of properties. If both `name` #' and a list-name are supplied, the list-name will be used. #' @returns An S7 property, i.e. a list with class `S7_property`. #' @export #' @examples #' # Simple properties store data inside an object #' Pizza <- new_class("Pizza", properties = list( #' slices = new_property(class_numeric, default = 10) #' )) #' my_pizza <- Pizza(slices = 6) #' my_pizza@slices #' my_pizza@slices <- 5 #' my_pizza@slices #' #' your_pizza <- Pizza() #' your_pizza@slices #' #' # Dynamic properties can compute on demand #' Clock <- new_class("Clock", properties = list( #' now = new_property(getter = function(self) Sys.time()) #' )) #' my_clock <- Clock() #' my_clock@now; Sys.sleep(1) #' my_clock@now #' # This property is read only, because there is a 'getter' but not a 'setter' #' try(my_clock@now <- 10) #' #' # Because the property is dynamic, it is not included as an #' # argument to the default constructor #' try(Clock(now = 10)) #' args(Clock) new_property <- function(class = class_any, getter = NULL, setter = NULL, validator = NULL, default = NULL, name = NULL) { class <- as_class(class) check_prop_default(default, class) if (!is.null(getter)) { check_function(getter, alist(self = )) } if (!is.null(setter)) { check_function(setter, alist(self = , value = )) } if (!is.null(validator)) { check_function(validator, alist(value = )) } out <- list( name = name, class = class, getter = getter, setter = setter, validator = validator, default = default ) class(out) <- "S7_property" out } check_prop_default <- function(default, class, error_call = sys.call(-1)) { if (is.null(default)) { return() # always valid. } if (is.call(default)) { # A promise default; delay checking until constructor called. return() } if (is.symbol(default)) { if (identical(default, quote(...))) { # The meaning of a `...` prop default needs discussion stop(simpleError("`default` cannot be `...`", error_call)) } if (identical(default, quote(expr =))) { # The meaning of a missing prop default needs discussion stop(simpleError("`default` cannot be missing", error_call)) } # other symbols are treated as promises return() } if (class_inherits(default, class)) return() msg <- sprintf("`default` must be an instance of %s, not a %s", class_desc(class), obj_desc(default)) stop(simpleError(msg, error_call)) } stop.parent <- function(..., call = sys.call(-2)) { stop(simpleError(.makeMessage(...), call)) } is_property <- function(x) inherits(x, "S7_property") #' @export print.S7_property <- function(x, ...) { cat(" \n") str_nest(x, "$", ...) } #' @export str.S7_property <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") print(object, ..., nest.lev = nest.lev) } prop_default <- function(prop, envir, package) { prop$default %||% class_construct_expr(prop$class, envir, package) } #' Get/set a property #' #' - `prop(x, "name")` / `prop@name` get the value of the a property, #' erroring if it the property doesn't exist. #' - `prop(x, "name") <- value` / `prop@name <- value` set the value of #' a property. #' #' @param object An object from a S7 class #' @param name The name of the parameter as a character. Partial matching #' is not performed. #' @param value A new value for the property. The object is automatically #' checked for validity after the replacement is done. #' @return `prop()` and `@` return the value of the property. #' `prop<-()` and `@<-` are called for their side-effects and return #' the modified object, invisibly. #' @export #' @examples #' Horse <- new_class("Horse", properties = list( #' name = class_character, #' colour = class_character, #' height = class_numeric #' )) #' lexington <- Horse(colour = "bay", height = 15, name = "Lex") #' lexington@colour #' prop(lexington, "colour") #' #' lexington@height <- 14 #' prop(lexington, "height") <- 15 prop <- function(object, name) { .Call(prop_, object, name) } propr <- function(object, name) { # reference implementation of `prop()` implemented in R check_is_S7(object) if (!prop_exists(object, name)) { stop(prop_error_unknown(object, name), call. = FALSE) } else { prop_val(object, name) } } signal_prop_error_unknown <- function(object, name) { stop(prop_error_unknown(object, name), call. = FALSE) } # Internal helper that assumes the property exists prop_val <- function(object, name) { val <- attr(object, name, exact = TRUE) if (is.null(val)) { prop <- prop_obj(object, name) if (!is.null(prop$getter)) { val <- prop$getter(object) } } val } # Get underlying property object from class prop_obj <- function(object, name) { class <- S7_class(object) attr(class, "properties")[[name]] } #' @rdname prop #' @param check If `TRUE`, check that `value` is of the correct type and run #' [validate()] on the object before returning. #' @export `prop<-` <- function(object, name, check = TRUE, value) { .Call(prop_set_, object, name, check, value) } `propr<-` <- local({ # reference implementation of `prop<-()` implemented in R # This flag is used to avoid infinite loops if you are assigning a property from a setter function setter_property <- NULL function(object, name, check = TRUE, value) { check_is_S7(object) prop <- prop_obj(object, name) if (is.null(prop)) { stop(prop_error_unknown(object, name), call. = FALSE) } if (!is.null(prop$getter) && is.null(prop$setter)) { msg <- sprintf("Can't set read-only property %s@%s", obj_desc(object), name) stop(msg, call. = FALSE) } if (!is.null(prop$setter) && !identical(setter_property, name)) { setter_property <<- name on.exit(setter_property <<- NULL, add = TRUE) object <- prop$setter(object, value) } else { if (isTRUE(check)) { error <- prop_validate(prop, value, object) if (!is.null(error)) { stop(error, call. = FALSE) } } attr(object, name) <- value } if (isTRUE(check) && is.null(setter_property)) { validate(object, properties = FALSE) } invisible(object) } }) # called from src/prop.c signal_prop_error <- function(fmt, object, name) { msg <- sprintf(fmt, obj_desc(object), name) stop(msg, call. = FALSE) } # called from src/prop.c signal_error <- function(msg) { stop(msg, call. = FALSE) } prop_error_unknown <- function(object, prop_name) { sprintf("Can't find property %s@%s", obj_desc(object), prop_name) } # called from src/prop.c prop_validate <- function(prop, value, object = NULL) { if (!class_inherits(value, prop$class)) { return(sprintf("%s must be %s, not %s", prop_label(object, prop$name), class_desc(prop$class), obj_desc(value) )) } if (is.null(validator <- prop$validator)) { return(NULL) } val <- validator(value) if (is.null(val)) { return(NULL) } if (is.character(val)) { if (length(val)) { return(paste0(prop_label(object, prop$name), " ", val)) } else { return(NULL) } } stop(sprintf( "%s validator must return NULL or a character, not <%s>.", prop_label(object, prop$name), typeof(val) )) } prop_label <- function(object, name) { sprintf("%s@%s", if (!is.null(object)) obj_desc(object) else "", name) } # Note: we need to explicitly refer to base with "base::`@`" in the # namespace directive to ensure the method is registered in the correct place. # Otherwise, loadNamespace()/registerS3method() gets confused by the # presence of a closure w/ the name of the generic (`@`) in the R7 namespace, # and incorrectly assumes that R7::`@` is the generic and registers the # method in the package namespace instead of base::.__S3MethodsTable__. #' @usage object@name #' @rawNamespace if (getRversion() >= "4.3.0") S3method(base::`@`, S7_object) #' @name prop `@.S7_object` <- prop #' @rawNamespace S3method("@<-",S7_object) `@<-.S7_object` <- `prop<-` #' Property introspection #' #' - `prop_names(x)` returns the names of the properties #' - `prop_exists(x, "prop")` returns `TRUE` iif `x` has property `prop`. #' #' @inheritParams prop #' @returns `prop_names()` returns a character vector; `prop_exists()` returns #' a single `TRUE` or `FALSE`. #' @export #' @examples #' Foo <- new_class("Foo", properties = list(a = class_character, b = class_integer)) #' f <- Foo() #' #' prop_names(f) #' prop_exists(f, "a") #' prop_exists(f, "c") prop_names <- function(object) { check_is_S7(object) if (inherits(object, "S7_class")) { # S7_class isn't a S7_class (somewhat obviously) so we fake the property names c("name", "parent", "package", "properties", "abstract", "constructor", "validator") } else { class <- S7_class(object) props <- attr(class, "properties", exact = TRUE) if (length(props) == 0) { character() } else { names(props) } } } # .AtNames not exported on r-devel yet, causes installation failure #' @rawNamespace if (getRversion() >= "4.3.0" && !is.null(asNamespace("utils")$.AtNames)) S3method(utils::.AtNames,S7_object) .AtNames.S7_object <- function(x, pattern = "") { # utils::findMatches gives `R CMD check` warning on current r-devel asNamespace("utils")$findMatches(pattern, prop_names(x)) } #' @rdname prop_names #' @export prop_exists <- function(object, name) { check_is_S7(object) name %in% prop_names(object) } #' Get/set multiple properties #' #' - `props(x)` returns all properties. #' - `props(x) <- list(name1 = val1, name2 = val2)` modifies an existing object #' by setting multiple properties simultaneously. #' - `set_props(x, name1 = val1, name2 = val2)` creates a copy of an existing #' object with new values for the specified properties. #' #' @importFrom stats setNames #' @inheritParams prop #' @param names A character vector of property names to retrieve. Default is all #' properties. #' @returns A named list of property values. #' @export #' @examples #' Horse <- new_class("Horse", properties = list( #' name = class_character, #' colour = class_character, #' height = class_numeric #' )) #' lexington <- Horse(colour = "bay", height = 15, name = "Lex") #' #' props(lexington) #' props(lexington) <- list(height = 14, name = "Lexington") #' lexington props <- function(object, names = prop_names(object)) { check_is_S7(object) if (length(names) == 0) { structure(list(), names = character(0)) } else { setNames(lapply(names, prop, object = object), names) } } #' @rdname props #' @export #' @param value A named list of values. The object is checked for validity #' only after all replacements are performed. `props<-` <- function(object, value) { check_is_S7(object) stopifnot(is.list(value)) for (name in names(value)) { prop(object, name, check = FALSE) <- value[[name]] } validate(object) object } #' @export #' @param ... Name-value pairs given property to modify and new value. #' @rdname props set_props <- function(object, ...) { props(object) <- list(...) object } as_properties <- function(x) { if (length(x) == 0) { return(list()) } if (!is.list(x)) { stop("`properties` must be a list", call. = FALSE) } out <- Map(as_property, x, names2(x), seq_along(x)) names(out) <- vapply(out, function(x) x$name, FUN.VALUE = character(1)) if (anyDuplicated(names(out))) { stop("`properties` names must be unique", call. = FALSE) } out } as_property <- function(x, name, i) { if (is_property(x)) { if (name == "") { if (is.null(x$name)) { msg <- sprintf("`properties[[%i]]` must have a name or be named.", i) stop(msg, call. = FALSE) } } else { x$name <- name } x } else { if (name == "") { msg <- sprintf("`properties[[%i]]` must be named.", i) stop(msg, call. = FALSE) } class <- as_class(x, arg = paste0("property$", name)) new_property(x, name = name) } } prop_is_read_only <- function(prop) { is.function(prop$getter) && !is.function(prop$setter) } prop_has_setter <- function(prop) is.function(prop$setter) prop_is_dynamic <- function(prop) is.function(prop$getter) S7/R/compatibility.R0000644000176200001440000000116414527735365013763 0ustar liggesusers# Where needed, attach an environment containing @ that works with S7 activate_backward_compatiblility <- function() { if (getRversion() < "4.3.0" && !"S7_at" %in% search()) { args <- list(list("@" = `@`), name = "S7_at", warn.conflicts = FALSE) do.call("attach", args) } invisible() } #' @aliases @ #' @usage NULL #' @rawNamespace if (getRversion() < "4.3.0") export(`@`) #' @name prop `@` <- function(object, name) { if (inherits(object, "S7_object")) { name <- as.character(substitute(name)) prop(object, name) } else { name <- substitute(name) do.call(base::`@`, list(object, name)) } } S7/vignettes/0000755000176200001440000000000014712722347012564 5ustar liggesusersS7/vignettes/spec/0000755000176200001440000000000014712722330013506 5ustar liggesusersS7/vignettes/spec/proposal.Rmd0000644000176200001440000002323614455512357016031 0ustar liggesusers--- title: "Proposal" description: > Proposal to RConsortium to create the working group. --- ## Executive summary Object-oriented programming enables R developers to implement abstractions, introduce domain-specific data models, and interface with external systems, among other things. Unlike other modern programming languages, R lacks a dominant approach to object-oriented programming. The competition between existing approaches is unproductive and contributes to social fragmentation of the community and technical hurdles when integrating across different systems. We propose to form a working group that will develop a design proposal for a system that will combine the most important elements from the existing approaches while remaining compatible with them. We will involve key technical experts and community stakeholders, including R Core and the tidyverse. Upon publishing the design proposal, we will invite the entire community to contribute feedback. Finally, we will conclude the working group by developing and releasing a strategy for implementing, maintaining, and adopting the framework. ## Background In R, everything is an object. That principle facilitates interacting with data, because a dataset is modeled as a tangible, real world object. The user can display the contents of an object, introspect its structure and manipulate it in various ways. R provides all of the basic types of objects necessary for statistical computing. To more effectively reason about a domain, like genomics, we need to specialize the data types to more richly model the semantics particular to that domain. Once we have a specialized set of data structures, we recognize the need for /abstraction/, which models commonality across data types. Abstraction is also useful for existing data types, where a package could provide an alternative implementation, for example, based on a database or distributed computing system. Abstraction requires a system of classification, where each object corresponds to a specific class, and each class derives from another. The classification system transcends the class instances (the objects), and it is helpful to explicitly refer to classes when programming. Fundamentally, a class-based object-oriented system has two requirements: * There is a centrally defined class hierarchy, and * Every object is an instance of a class. A class is defined by the contract governing its structure and contents. The contract extends the contract of the parent class in order to add semantics through additional constraints while remaining compatible with the parent contract. Code manipulating objects will often make assumptions about the structure and content of objects. To mitigate risk, such low-level code benefits from a validation function, essentially a codification of the class contract, to verify its assumptions. While there is intrinsic value in formal modeling of data, for software to fully take advantage of the richer semantics, it requires /polymorphism/, where the behavior of the software with respect to an object depends on the class of the object. Most object-oriented languages implement message-passing OOP, where classes define their own behavior by holding functions, called methods, in addition to fields. When one class calls a method in another class, it passes a message. R has a few systems based on message-passing, most notably the R6 package and reference classes in the methods package. These rely on message-passing in part because their objects are mutable and it is easier to reason about code when we can typically assume that it is the receiver being mutated. We exclude from our scope systems with mutable objects, because immutable objects are generally preferable for interactive data analysis, relegating mutable systems to niche applications, such as GUIs and caching mechanisms. As appropriate for a statistical computing language, R has functional roots, and the most prevalent object-oriented approaches in R are functional systems, namely S3 and S4, corresponding to the third and fourth version of the S language, respectively. Objects tend to be immutable, and top-level functions can be generic, which means means they dispatch to another function, called a method, based on the types of the passed arguments. The simplest type of generic dispatches on a single argument. While single dispatch supports most applications of polymorphism, there are many cases where the behavior depends on the interaction of two or more classes. Typical examples include arithmetic, converting an object from one class to another and combining two different types of object. From these considerations, we conclude that a good object-oriented system would support: * An explicit class hierarchy (represented by reified objects) with * Systematic instance construction and validation; * Multiple, at least double, dispatch, and * Objects with a transparent, introspectable structure. ## Problem statement The two major OOP frameworks in R, S3 and S4, each have their own limitations, with neither one being sufficiently applicable to gain dominance. This had led to social fracturing in the community and technical impediments to compatibility and interoperability. We summarize those limitations in the table below. | S3 limitations | S4 limitations | S4 implementation issues | |---------------------------------+------------------------------------------------------+--------------------------| | Classes are only implicit | Multiple inheritance and dispatch hard to understand | Poor performance | | No systematic object validation | Syntax is unusual (side effects) | Difficult to maintain | | Single dispatch only | Lack of transparency of object structure and methods | | S3 defines classes implicitly at the instance level, so there is no explicit class hierarchy. While the S3 system supports tracking the class of every object, there is no systematic means of constructing and validating them to ensure correctness. S3 only supports single dispatch, so it is difficult to write polymorphic code for arithmetic, merging objects, converting objects, etc. S4 has solutions to all of those problems, but it is quite ambitious, introducing significant complexity, unusual syntax and loss of transparency. Multiple inheritance, while expressive and powerful, allows for multiple overlapping taxonomies, which is difficult to reason about, and the difficulty increases quadratically when combined with multiple dispatch, where method selection uses a distance calculation in /n/ dimensions where /n/ is the number of arguments. The syntax for defining classes and methods is non-idiomatic and relies on side effects. Finally, the S4 convention (although not a requirement) is to hide slots behind an API, which improves encapsulation but prevents the basic introspection capabilities that are desirable when analyzing data and that R users have come to expect. Somewhat tangentionally, but still motivating, there are also technical issues with the methods package, the only implementation of the S4 system. Its incremental growth over the decades has led to excessive complexity, as well as performance issues. In the absence of a new system, we would need to reimplement S4, so there will be implementation effort regardless. Documentation limitations afflict both S3 and S4. It is difficult to describe a programming interface when it consists of generic functions not coupled to each other or any class. Any package can define a method on a generic or extend a class, so the documentation needs to adapt according to which packages are loaded. ## Proposal We believe there may be a better way, but the solutions are not obvious. Across popular programming languages, with the notable exception of Julia, functional OOP is much less common and less well developed than message-passing, so there are few examples for R to follow and any advances will likely require research. Therefore, we propose to bring together a panel of experts to more formally assess the situation and design a solution. Since we are aiming for this solution to unify the community, we aim for widespread adoption, which will require involvement by key community leaders. We will invite the community to review the proposal and to contribute feedback and ideas. The working group will integrate the feedback and finalize the proposal. It will conclude after developing a strategy for implementation, adoption and long-term maintenance, for which it will not be directly responsible. No funding is required nor requested for this effort. ## Objectives * Release a finalized design specification for a unifying object-oriented programming system, * Recommend to the ISC a strategy for implementing and maintaining the system, as well as driving its adoption. ## Milestones * Finalize membership, * Agree upon and prioritize system requirements, * Iterate through design proposals, * Release a proposal for community review and contribution, * Incorporate community contributions, * Submit the finalized proposal, * Develop and submit the implementation and adoption strategy. ## Membership The founding members are: * Michael Lawrence :: Representing R-core and (S4-based) Bioconductor, and a maintainer of the methods package; * Hadley Wickham :: Representing RStudio and the tidyverse project, which relies heavily on S3; * Martin Maechler :: Representing R-core, maintainer of the S4-based Matrix and Rmpfr packages, and a maintainer of the methods package. We have also invited representatives from the R Ladies and ROpenSci communities. We will collaborate with others in R Core, keeping them informed of our plans and incorporating any feedback. S7/vignettes/spec/requirements.Rmd0000644000176200001440000002067014527735365016722 0ustar liggesusers--- title: "Requirements" description: > Initial technical requirements brainstorming. --- This page is for brainstorming on the technical requirements for solving our [problem](https://github.com/RConsortium/S7/wiki/Problem-Statement). Once we align on the requirements, we can start the design process. ## List of requirements 1. The system should be as compatible as possible with existing systems, particularly S3 2. Classes should be first class objects, extrinsic from instances 3. The system should support formal construction, casting, and coercion to create new instances of classes. 4. It should be convenient to systematically validate an instance 5. Double dispatch, and possibly general multiple dispatch, should be supported 6. Inheritance should be as simple as possible, ideally single (other features might compensate for the lack of multiple inheritance) 7. Syntax should be intuitive and idiomatic, and should not rely on side effects nor loose conventions 8. Namespace management should not be any more complicated than S3 currently 9. Performance should be competitive with existing solutions 10. The design should be simple to implement 11. It should be possible for a package to define a method where the generic and classes are defined outside of the package 12. We should aim to facilitate API evolution, particularly as it relates to inter-package dependencies 13. Methods must include all formal arguments from their generic (not like Julia) 14. Generics should support `...` in their formal argument lists and methods can append arguments to those lists 15. Fields should have "public" visibility, and should support encapsulation (implicit getters and setters) 16. The system should support reflection 17. The system should support lazy and dynamic registration of classes and methods. ## Compatibility Ideally the new system will be an extension of S3, because S3 is already at the bottom of the stack and many of the other systems have some compatibility with S3. ## Classes as first class objects It is important for classes to be defined extrinsically from instances, because it makes the data contract more obvious to both developers (reading the code) and users (interacting with objects). S4 represents classes as proper objects; however, typically developers will only refer to the classes by name (string literal) when interacting with the S4 API. Interacting directly with objects instead would likely simplify the API (syntax) and its implementation. ## Generics as extended function objects Generic functions should be represented by a special class of function object that tracks its own method table. This puts generic functions at the same level as classes, which is the essence of functional OOP, and will likely enable more natural syntax in method registration. ## Formal instantiation and type conversion Class instantiation should happen through a formal constructor. Once created, an object should keep its original class unless subjected to formal casting or formal coercion. The class of an object should be robust and predictable, and direct class assignment (e.g. `class<-()`) should generally be avoided. ## Systematic validation Class contracts are often more complicated than a simple list of typed fields. Having a formally supported convention around validating objects is important so that code can make the necessary assumptions about data structures and their content. Otherwise, developers trying to be defensive will resort to ad hoc checks scattered throughout the code. ## Multiple dispatch The system will at least need to support double dispatch, so that code can be polymorphic on the interaction of two arguments. There are many obvious examples: arithmetic, serialization (object, target), coercion, etc. It is less likely that we will require dispatch beyond two arguments, and any advantages are probably outweighed by the increase in complexity. In many cases of triple dispatch or higher in the wild, developers are abusing dispatch to implement type checks, instead of polymorphism. Almost always, we can deconstruct multiple dispatch into a series of double dispatch calls. General multiple dispatch makes software harder to understand and is more difficult to implement. ## Inheritance Inheritance lets us define a data taxonomy, and it is often natural to organize a set of data structures into multiple, orthogonal taxonomies. Multiple inheritance enables that; however, it also adds a lot of complexity, both to the software relying on it and the underlying system. It is often possible and beneficial (in the long term) to rely on techniques like composition and delegation instead. We should consider how single inheritance languages like Java have been so successful, although they are not directly comparable to our functional system. ## Syntax The entire API should be free of side effects and odd conventions, like making the `.` character significant in method names. Whereas S3 supports implicit method registration based on the name of the method, the new system should require methods to be registered explicitly. Direct manipulation of class and generic objects should enable this. ## Namespaces The system should support exporting generics and classes. If classes are objects, they can be treated like any other object when exporting and importing symbols. If generics are objects, then it should be simple to export all methods on a generic. It is not clear whether selective method export is important. One use case would be to hide a method with an internal class in its signature to avoid unnecessary documentation. Perhaps `R CMD check` could ignore methods for unexported classes. There should be no need for explicit method registration. ## Third party methods To fully realize the potential of interoperability afforded by functional OOP, with its treating of generics and classes as orthogonal, we should allow packages to extend an externally defined API so that it supports externally defined classes. In most cases, a method should only be defined by either the owner of the generic or the owner of the class, but "ownership" is a somewhat nebulous concept. We acknowledge the potential for conflicts arising from multiple packages defining methods on the same generic and with overlapping signatures, as well as the danger of injecting new behaviors that violate the assumptions of existing method definitions. ## Formal arguments The formal arguments of a generic must be present in every method for that generic. This is in contrast to Julia, where methods can have completely different sets of arguments. We favor a fixed set of formal arguments for the sake of consistency and to enable calling code to depend on a minimal set of arguments that are always present. If the generic formal argument list includes `...`, then methods can add their own arguments. The extra arguments are useful for controlling specialized behaviors, as long as the calling code can assume that calling the generic will always dispatch to a method that handles them in accordance with the documentation. In accordance with the Liskov Substitution Principle, we could explore enforcing that a method only adds arguments to those of a method dispatching on a parent class. This is easiest to conceptualize and would be most useful in the single dispatch case, but we should also be able to develop a set of rules for nested multiple dispatch. ## Field visibility Functional OOP is incompatible with the notion of private fields, because code does not run in the context of a class, and thus there is no way to accept or deny access to a field. R users also expect and appreciate object transparency. We will consider enabling encapsulation of field access and modification similar to how reference classes allow for defining fields as active bindings. ## Reflection and dynamism Given a class and a generic, you should be able to find the appropriate method without calling it. This is important for building tooling around the system. ## Lazy and dynamic registration On the flip side, you should also be able to register a method lazily/dynamically at run-time. This is important for: - Generics and classes in suggested packages, so that method registration can occur when the dependency is loaded. - Testing, since you may want to define a method only within a test. This is particularly useful when used to eliminate the need for mocking. - Interface evolution, so you can provide a method for a generic or class that does not yet exist, anticipating a future release of a dependency. S7/vignettes/spec/design.Rmd0000644000176200001440000002563414455512357015447 0ustar liggesusers--- title: "Design specification" description: > Design specification used to guide the implementation. --- This document presents a broad overview of the S7 object-oriented programming toolkit. (Please note that S7 is a working name and may change in the future.) ## Objects We define an S7 object as any R object with: - A class object attribute, a reference to the **class object**, and retrieved with `classObject()`. - For S3 compatibility, a class attribute, a character vector of class names. - Additional attributes storing **properties** defined by the class, accessible with `@`/`prop()`. ## Classes S7 classes are first class objects (Req2) with the following components: - **Name**, a human-meaningful descriptor for the class. This is used for the default print method and in error messages; it does not identify the class. - **Parent**, the class object of the parent class. This implies single inheritance (Req6). - A **constructor**, an user-facing function used to create new objects of this class. It always ends with a call to `newObject()` to initialize the class. This the function (wrapped appropriately) that represents the class. - **A validator**, a function that takes the object and returns `NULL` if the object is valid, otherwise a character vector of error messages (like the methods package). - **Properties**, a list of property objects (see below) that define the data that objects can possess. Classes are constructed by supplying these components to a call to `newClass()`. `newClass()` returns a class object that can be called to construct an object of that class. ``` r newClass( name, parent = Object, constructor = function(...) newObject(...), validator = function(x) NULL, properties = list() ) ``` For example: ``` r Range <- newClass("Range", Vector, constructor = function(start, end) { stopifnot(is.numeric(start), is.numeric(end), end >= start) newObject(start = start, end = end) }, validator = function(x) { if (x@end < x@start) { "end must be greater than or equal to start" } }, properties = c(start = "numeric", end = "numeric") ) Range(start = 1, end = 10) ``` ### Initialization The constructor uses `newObject()` to **initialize** a new object. This: 1. Inspects the enclosing scope to find the "current" class. 2. Creates the prototype, by either by calling the parent constructor or by creating a base type and adding `class` and `classObject` attributes to it. 3. Validates properties then adds to prototype. 4. Validates the complete object. Steps 2 and 3 are similar to calling `structure()`, except that property values are initialized and validated through the property system. ### Shortcuts By convention, any argument that takes a class object can instead take the name of a class object as a string. The name will be used to find a class object in the calling frame. Similarly, instead of providing a list of property objects, you can instead provide a named character vector. For example, `c(name = "character", age = "integer")` is shorthand for `list(newProperty("name", "character"), newProperty("age", "integer"))`. ### Validation Objects will be validated on initialization and every time a property is modified. To temporarily opt-out of validation (e.g. in order to transition through a temporarily invalid state), S7 provides `eventuallyValid()`: ``` r eventuallyValid <- function(object, fun) { object$internal_validation_flag <- FALSE out <- fun(object) out$internal_validation_flag <- TRUE validate(out) } ``` For example, if you wanted to move a Range object to the right, you could write: ``` r move_right <- function(x, y) { eventuallyValid(x, function(x) { x@start <- x@start + y x@end <- x@end + y x }) } ``` This ensures that the validation will not trigger if `x@start + y` is greater than `x@end`. S7 also provides `implicitlyValid()` for expert use. This is similar to `eventuallyValid()` but does not check for validity at the end. This can be used in performance critical code where you can ascertain that a sequence of operations can never make a valid object invalid. (This can be quite hard: for example, in the `move_right()` example above, you might think that that if `x@start < x@end` is true at the beginning, then `x@start + y < x@end + y` will still be true at the end, and you don't need to re-validate the object. But that's not necessarily true: if `x@start == 1`, `x@end == 2`, and `abs(y) > 2e16` then `x@start + y == x@end + y`!) ### Unions A class union represents a list of possible classes. It is used in properties to allow a property to be one of a set of classes, and in method dispatch as a convenience for defining a method for multiple classes. ``` r ClassUnion <- defineClass("ClassUnion", properties = list(classes = "list"), validator = function(x) { # Checks that all elements of classes are Class object }, constructor = function(...) { classes <- list(...) # look up Class object from any class vectors newObject(classes = classes) } ) ClassUnion("character", "NULL") ClassUnion(Range, NULL) ``` ## Properties Properties store the data needed by an object. Properties of an object can be accessed using `@`/`@<-` or `prop()`/`prop<-`. Setting the properties of an object always triggers validation. Properties are less encapsulated than their equivalents in most languages because R users expect transparency and want to get to the actual data inside an object and directly manipulate it to get their work done. Properties this support typical usage while still providing some ability to encapsulate data and hide implementation details. Every property definition has a: - A **name**, used to label output for humans. - An optional **class** (or class union). - An optional **accessor** function that overrides getting and setting, much like an active binding (by default, the value is stored as attribute, like S3/S4). Property objects are created by `newProperty()`: ``` r newProperty( name, class = NULL, accessor = NULL ) ``` Compared to S3 attributes, properties are considerably stricter: a class defines the names and types of its properties. Compared to S4 slots, properties enable an object to change its internals without breaking existing usage because it can provides a custom accessor that redirects to the new representation. There will be built-in support for emitting deprecation messages. While it would be tempting to support public vs. private scoping on properties, it is not obvious how to do so, because no code is more privileged than any another. Nor is it clear whether the package should define the boundary, when packages sometimes define methods on classes defined in other packages and want to take advantage of their internal representations. We believe that the encapsulation afforded by properties is a good compromise. ## Generics A generic separates function interface from implementation: the generic defines the interface, and methods provide the implementation. For introspection purposes, it knows its name and the names of the arguments in its signature (the arguments considered during dispatch). Calling `newGeneric()` defines a new generic. It has the signature: ``` r newGeneric(name, FUN, signature) ``` The `signature` would default to the first argument, i.e. `formals(FUN)[1]`. The body of `FUN` would resemble S3 and S4 generics. It might just call `UseMethod()`. By convention, any argument that takes a generic function, can instead take the name of a generic function supplied as a string. The name will be used to find the class object in the calling frame. ## Methods ### Creation Methods are defined by calling `method<-(generic, signature, method)`: ``` r method(generic, signature) <- function(x, ...) {} ``` - `generic` is a generic function. - `signature` is a single class object, a class union, list of class objects/unions, or a character vector. - `method` is a compatible function, i.e. all arguments before `...` have the same names in the same order; if the generic doesn't have `...` all arguments must be same. Documentation will discuss the risks of defining a method when you don't own either the generic or the class. `method<-` is designed to work at run-time (not just package build-time) so that methods can be defined when packages that define classes or generics are loaded after the package that defines the methods. This typically occurs when providing methods for generics or classes in suggested packages. ``` r whenLoaded("pkg", { method(mean, pkg::A) <- function() 10 method(sum, pkg::A) <- function() 5 }) ``` ### Dispatch Dispatch is nested, meaning that if there are multiple arguments in the generic signature, it will dispatch on the first argument, then the second. Nested dispatch is likely easier to predict and understand compared to treating all arguments with equal precedence. Nested dispatch is also easier to implement efficiently, because classes would effectively inherit methods, and we could implement that inheritance using environments. For example, a `plot()` generic dispatching on `x` could be implemented like this: ``` r plot <- function(x) { method(plot, classObject(x))(x) } ``` While a `publish()` that publishes an object `x` to a destination `y`, dispatching on both arguments, could be implemented as: ``` r publish <- function(x, y, ...) { sig <- list(classObject(x), classObject(y)) method(publish, sig)(x, y, ...) } ``` Because method dispatch is nested, this is presumably equivalent to something like: ``` r publish <- function(x, y, ...) { publish_x <- method(publish, classObject(x)) publish_xy <- method(publish_x, classObject(y)) publish_xy(x, y, ...) } ``` Alternatively, the generics could just call `UseMethod()`, which would gain support for nested dispatch. ## Compatibility ### S3 Since the class attribute has the same semantics as S3, S3 dispatch should be fully compatible. The new generics should also be able to handle legacy S3 objects. ### S4 In principle, we could modify the methods package so that S4 generics can operate on the new class definitions. Since the new generics will fallback to S3 dispatch, they should support S4 objects just as S3 generics support them now. ## Documentation The primary challenge is that the availability of methods and classes depends on which packages are installed, so we will need to generate index pages that list the methods for a generic or the methods with a particular class in their signature. The documentation blurbs could be lazily scraped at runtime to build an index, similar to how the help search index is created now. We would then generate help pages from the index. The index of installed methods could provide additional benefits, including introspection. A generic could prompt the user to load a package if it fails to find an applicable method, while there is an installed, unloaded method available. This case would arise when a method is defined outside of the packages that define the class and generic. S7/vignettes/spec/dispatch.Rmd0000644000176200001440000001504314632315646015765 0ustar liggesusers--- title: "Dispatch" description: Initial notes on dispatch design --- ```{r, include = FALSE} knitr::opts_chunk$set(comment = "#>", collapse = TRUE) ``` ## Single dispatch ### S3 The basic rules of S3 dispatch are simple. If object has class attribute `c("a", "b", "c")` then generic `f()` looks for methods in the following order: - `f.a()` - `f.b()` - `f.c()` - `f.default()` If no method is found, it errors. ### S7 S7 will behave the same as S3. ## Method lookup ### S3 Where precisely does `UseMethod()` look for the methods? As of R 4.0.0, it looks in the following three places: - The method table is a special environment `.__S3MethodsTable__.` found in the environment where the generic is defined. - The chain of environments starting at the `parent.frame()` of the call to generic, ending at the global environment. - The base environment (i..e. skips the search). ### S7 S7 methods are defined using assignment: ```{r, eval = FALSE} method("mean", "numeric") <- function(x) sum(x) / length(x) ``` Behind the scenes, this acts directly upon the method table, so method lookup for S7 generics never needs to look in the parent frame. `method<-` is likely to start as a shim around `.S3method()` but we may want to consider a separate `.__S7MethodsTable__.`. This could use a new data structure that resolves generic/class ambiguity (e.g. `all.equal.data.frame()`). Methods for S7 classes defined on an S3 generics would still use the S3 method table. Could consider attaching the method table to the generic, instead of its containing environment. Method lookup would be cached for performance, so that it is only performed once per class. Cached methods would be marked with a special attribute so that they could be flushed whenever a new method for the generic is added. ## Method call frame ### S3 Once the method has been found, it must be called. `UseMethod()` does not work like a regular function call but instead: - Changes to arguments are ignored. - Method can access objects created in generic. (Changed in R 4.4.0.) - The parent frame of the method call is the parent frame of the generic. These properties are summarised in the following example: ```{r} foo <- function(x, y) { y <- 2 z <- 2 UseMethod("foo") } foo.numeric <- function(x, y) { print(parent.frame()) c(x = x, y = y, z = z) } ``` ```{r} #| eval: false # In R 4.3 and earlier foo(1, 1) #> x y z #> 1 1 2 ``` ```{r} #| error: true foo(1, 1) ``` ### S7 - Can we eliminate the special behaviour and make it just like a regular function call? Presumably easier than changing dispatch rules because we'll call a function other than `UseMethod()`. - Need to make precise how arguments are passed to the method. `plot()` at least assumes that this works: ```{r} foo <- function(x, y) { UseMethod("foo") } foo.numeric <- function(x, y) { deparse(substitute(x)) } x <- 10 foo(x) ``` How does that intersect with assignment within the generic? ## Inheritance ### S3 i.e. how does `NextMethod()` work: currently most state recorded in special variables like `.Generic`, etc. Can we avoid this confusion: ```{r} foo <- function(x) { UseMethod("foo") } foo.a <- function(x) { x <- factor("x") NextMethod() } foo.b <- function(x) { print("In B") print(class(x)) } foo(structure(1, class = c("a", "b"))) ``` ### S4 Want to avoid this sort of code, where we rely on magic from `callGeneric()` to pass on values from current call. ```{r, eval = FALSE} method("mean", "foofy") <- function(x, ..., na.rm = TRUE) { x <- x@values callGeneric() } ``` ### S7 Can we require `generic` and `object` arguments to make code easier to reason about? ```{r, eval = FALSE} method("mean", "POSIXct") <- function(x) { POSIXct(NextMethod(), tz = attr(x, "tz")) } # Explicit is nice: method("mean", "POSIXct") <- function(x) { POSIXct(NextMethod("mean", x), tz = attr(x, "tz")) } # But what does this do? Is this just an error? method("mean", "POSIXct") <- function(x) { POSIXct(NextMethod("sd", 10), tz = attr(x, "tz")) } ``` ## Group generics ### S3 Group generics (`Math`, `Ops`, `Summary`, `Complex`): exist for some internal generics. Looked for before final fallback. ```{r} sloop::s3_dispatch(sum(Sys.time())) ``` ### S7 Keep as is. ## Double dispatch ### S3 Used by Ops group generic. Basic process is find method for first and second arguments. Then: - If same, ok - If one internal, use other - Otherwise, warn and use internal ### S7 Goal is to use iterated dispatch which implies asymmetry in dispatch order. User responsible for ensuring that `x + y` equivalent to `y + x` (types should almost always be the same, but values are likely to be different). ```{r} double_dispatch <- function(x, y, generic = "+") { grid <- rev(expand.grid(sloop::s3_class(y), sloop::s3_class(x))) writeLines(paste0("* ", generic, ".", grid[[1]], ".", grid[[2]])) } ab <- structure(list(), class = c("a", "b")) cd <- structure(list(), class = c("c", "d")) double_dispatch(ab, cd) double_dispatch(cd, ab) double_dispatch(1, 1L) ``` In vctrs, some question if we will remove inheritance from all double dispatch. We have already done so for `vec_ptype2()` and `vec_cast()` because the coercion hierarchy often does not match the class hierarchy. May also do for `vec_arith()`. ## Implicit class ### S3 When `UseMethod()` receives an object without a `class` attribute, it uses the **implicit** class, as provided by `.class2()`. This is made up of four rough categories: dimension, type, language, numeric. ```{r} # dimension class .class2(matrix("a")) .class2(array("a")) # typeof(), with some renaming .class2(sum) .class2(quote(x)) # language class .class2(quote({})) # similarly for if, while, for, =, <-, ( # numeric .class2(1) ``` Note that internal generics behave differently, instead immediately falling back to the default default case. ### S7 Suggest defining a new `r7class()` function that returns a simplified implicit class, dropping the language classes. Dispatch should use the same rules in R and in C. (But are there performance implications?) ## Multi-dispatch ### S3 Special dispatch? `c()`, `cbind()`, `rbind()` (+ `cbind2()` and `rbind2()`) --- iterated double dispatch. Need to describe in more detail so we have a more solid assessment of what S7 might need.ez - gitDot-dot-dot dispatch, assumes all have same class - vctrs used two pass approach (find type then coerce) ### S7 Initially, don't provide support for user generics that dispatch on `…`? Instead suggest people use `Reduce` plus double-dispatch. S7/vignettes/compatibility.Rmd0000644000176200001440000001034114712423107016070 0ustar liggesusers--- title: "Compatibility with S3 and S4" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Compatibility with S3 and S4} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` S7 is designed to be compatible with S3 and S4. This vignette discusses the details. ```{r setup} library(S7) ``` ## S3 S7 objects *are* S3 objects, because S7 is implemented on top of S3. There are two main differences between an S7 object and an S3 object: - As well as the `class` attribute possessed by S3 objects, S7 objects have an additional `S7_class` attribute that contains the object that defines the class. - S7 objects have properties; S3 objects have attributes. Properties are implemented on top of attributes, so you can access them directly with `attr` and friends. When working inside of S7, you should never use attributes directly, but it does mean that existing code will continue to work. All up, this means most usage of S7 with S3 will just work. - S7 can register methods for: - S7 class and S3 generic - S3 class and S7 generic - S7 classes can extend S3 classes - S3 classes can extend S7 classes ### Methods `method()` is designed to be the single tool for method registration that you need when working with S7 classes. You can also register a method for an S7 class and S3 generic without using S7, because all S7 objects have S3 classes, and S3 dispatch will operate on them normally. ```{r} Foo <- new_class("Foo") class(Foo()) mean.Foo <- function(x, ...) { "mean of foo" } mean(Foo()) ``` ### Classes It's possible to extend an S7 class with S3. This is primarily useful because in many cases it allows you to change a class hierarchy from the inside out: you can provide a formal definition of an S3 class using S7, and its subclasses don't need to change. ### List classes Many simple S3 classes are implemented as lists, e.g. rle. ```{r} rle <- function(x) { if (!is.vector(x) && !is.list(x)) { stop("'x' must be a vector of an atomic type") } n <- length(x) if (n == 0L) { new_rle(integer(), x) } else { y <- x[-1L] != x[-n] i <- c(which(y | is.na(y)), n) new_rle(diff(c(0L, i)), x[i]) } } new_rle <- function(lengths, values) { structure( list( lengths = lengths, values = values ), class = "rle" ) } ``` There are two ways to convert this to S7. You could keep the structure exactly the same, using a `list` as the underlying data structure and using a constructor to enforce the structure: ```{r} new_rle <- new_class("rle", parent = class_list, constructor = function(lengths, values) { new_object(list(lengths = lengths, values = values)) } ) rle(1:10) ``` Alternatively you could convert it to the most natural representation using S7: ```{r} rle <- new_class("rle", properties = list( lengths = class_integer, values = class_atomic )) ``` To allow existing methods to work you'll need to override `$` to access properties instead of list elements: ```{r} method(`$`, rle) <- prop rle(1:10) ``` The chief disadvantage of this approach is any subclasses will need to be converted to S7 as well. ## S4 S7 properties are equivalent to S4 slots. The chief difference is that they can be dynamic. - S7 classes can not extend S4 classes - S4 classes can extend S3 classes - S7 can register methods for: - S7 class and S4 generic - S4 class and S7 generic ### Unions S4 unions are automatically converted to S7 unions. There's an important difference in the way that class unions are handled in S4 and S7. In S4, they're handled at method dispatch time, so when you create `setUnion("u1", c("class1", "class2"))`, `class1` and `class2` now extend `u1`. In S7, unions are handled at method registration time so that registering a method for a union is just short-hand for registering a method for each of the classes. ```{r} Class1 <- new_class("Class1") Class2 <- new_class("Class2") Union1 <- new_union(Class1, Class2) foo <- new_generic("foo", "x") method(foo, Union1) <- function(x) "" foo ``` S7 unions allow you to restrict the type of a property in the same way that S4 unions allow you to restrict the type of a slot. S7/vignettes/generics-methods.Rmd0000644000176200001440000002503414712423107016464 0ustar liggesusers--- title: "Generics and methods" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Generics and methods} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` This vignette dives into the details of S7 generics and method dispatch, building on the basics discussed in `vignette("S7")`. We'll first introduce the concept of generic-method compatibility, then discuss some of the finer details of creating a generic with `new_generic()`. This vignette first discusses generic-method compatibility, and you might want to customize the body of the generic, and generics that live in suggested packages. We'll then pivot to talk more details of method dispatch including `super()` and multiple dispatch. ```{r setup} library(S7) ``` ## Generic-method compatibility When you register a method, S7 checks that your method is compatible with the generic. The formal arguments of the generic and methods must agree. This means that: - Any arguments that the generic has, the method must have too. In particular, the arguments of the method start with the arguments that the generic dispatches on, and those arguments must not have default arguments. - The method can contain arguments that the generic does not, as long as the generic includes `…` in the argument list. ### Generic with dots; method without dots The default generic includes `…` but generally the methods should not. That ensures that misspelled arguments won't be silently swallowed by the method. This is an important difference from S3. Take a very simple implementation of `mean()`: ```{r} mean <- new_generic("mean", "x") method(mean, class_numeric) <- function(x) sum(x) / length(x) ``` If we pass an additional argument in, we'll get an error: ```{r, error = TRUE, eval = FALSE} mean(100, na.rm = TRUE) ``` But we can still add additional arguments if we desired: ```{r} method(mean, class_numeric) <- function(x, na.rm = TRUE) { if (na.rm) { x <- x[!is.na(x)] } sum(x) / length(x) } mean(c(100, NA), na.rm = TRUE) ``` (We'll come back to the case of requiring that all methods implement a `na.rm = TRUE` argument shortly.) ### Generic and method with dots There are cases where you do need to take `…` in a method, which is particularly problematic if you need to re-call the generic recursively. For example, imagine a simple print method like this: ```{r} simple_print <- new_generic("simple_print", "x") method(simple_print, class_double) <- function(x, digits = 3) {} method(simple_print, class_character) <- function(x, max_length = 100) {} ``` What if you want to print a list? ```{r} method(simple_print, class_list) <- function(x, ...) { for (el in x) { simple_print(el, ...) } } ``` It's fine as long as all the elements of the list are numbers, but as soon as we add a character vector, we get an error: ```{r, error = TRUE, eval = FALSE} simple_print(list(1, 2, 3), digits = 3) simple_print(list(1, 2, "x"), digits = 3) ``` To solve this situation, methods generally need to ignore arguments that they haven't been specifically designed to handle, i.e. they need to use `…`: ```{r} method(simple_print, class_double) <- function(x, ..., digits = 3) {} method(simple_print, class_character) <- function(x, ..., max_length = 100) {} simple_print(list(1, 2, "x"), digits = 3) ``` In this case we really do want to silently ignore unknown arguments because they might apply to other methods. There's unfortunately no easy way to avoid this problem without relying on fairly esoteric technology (as done by `rlang::check_dots_used()`). ```{r} simple_print(list(1, 2, "x"), diggits = 3) ``` ### Generic and method without dots Occasional it's useful to create a generic without `…` because such functions have a useful property: if a call succeeds for one type of input, it will succeed for any type of input. To create such a generic, you'll need to use the third argument to `new_generic()`: an optional function that powers the generic. This function has one key property: it must call `call_method()` to actually perform dispatch. In general, this property is only needed for very low-level functions with precisely defined semantics. A good example of such a function is `length()`: ```{r, eval = FALSE} length <- new_generic("length", "x", function(x) { S7_dispatch() }) ``` Omitting `…` from the generic signature is a strong restriction as it prevents methods from adding extra arguments. For this reason, it's should only be used in special situations. ## Customizing generics In most cases, you'll supply the first two arguments to `new_generic()` and allow it to automatically generate the body of the generic: ```{r} display <- new_generic("display", "x") S7_data(display) ``` The most important part of the body is `S7_dispatch()`; this function finds the method the matches the arguments used for dispatch and calls it with the arguments supplied to the generic. It can be useful to customize this body. The previous section showed one case when you might want to supply the body yourself: dropping `…` from the formals of the generic. There are three other useful cases: - To add required arguments. - To add optional arguments. - Perform some standard work. A custom `fun` must always include a call to `call_method()`, which will usually be the last call. ### Add required arguments To add required arguments that aren't dispatched upon, you just need to add additional arguments that lack default values: ```{r} foo <- new_generic("foo", "x", function(x, y, ...) { S7_dispatch() }) ``` Now all methods will need to provide that `y` argument. If not, you'll get a warning: ```{r} method(foo, class_integer) <- function(x, ...) { 10 } ``` This is a warning, not an error, because the generic might be defined in a different package and is in the process of changing interfaces. You'll always want to address this warning when you see it. ### Add optional arguments Adding an optional argument is similar, but it should generally come after `…`. This ensures that the user must supply the full name of the argument when calling the function, which makes it easier to extend your function in the future. ```{r} mean <- new_generic("mean", "x", function(x, ..., na.rm = TRUE) { S7_dispatch() }) method(mean, class_integer) <- function(x, na.rm = TRUE) { if (na.rm) { x <- x[!is.na(x)] } sum(x) / length(x) } ``` Forgetting the argument or using a different default value will again generate a warning. ```{r} method(mean, class_double) <- function(x, na.rm = FALSE) {} method(mean, class_logical) <- function(x) {} ``` ### Do some work If your generic has additional arguments, you might want to do some additional work to verify that they're of the expected type. For example, our `mean()` function could verify that `na.rm` was correctly specified: ```{r} mean <- new_generic("mean", "x", function(x, ..., na.rm = TRUE) { if (!identical(na.rm, TRUE) && !identical(na.rm = FALSE)) { stop("`na.rm` must be either TRUE or FALSE") } S7_dispatch() }) ``` The only downside to performing error checking is that you constraint the interface for all methods; if for some reason a method found it useful to allow `na.rm` to be a number or a string, it would have to provide an alternative argument. ## `super()` Sometimes it's useful to define a method for in terms of its superclass. A good example of this is computing the mean of a date --- since dates represent the number of days since 1970-01-01, computing the mean is just a matter of computing the mean of the underlying numeric vector and converting it back to a date. To demonstrate this idea, I'll first define a mean generic with a method for numbers: ```{r} mean <- new_generic("mean", "x") method(mean, class_numeric) <- function(x) { sum(x) / length(x) } mean(1:10) ``` And a Date class: ```{r} date <- new_class("date", parent = class_double) # Cheat by using the existing base .Date class method(print, date) <- function(x) print(.Date(x)) date(c(1, 10, 100)) ``` Now to compute a mean we write: ```{r} method(mean, date) <- function(x) { date(mean(super(x, to = class_double))) } mean(date(c(1, 10, 100))) ``` Let's unpack this method from the inside out: 1. First we call `super(x, to = class_double)` --- this will make the call to next generic treat `x` like it's a double, rather than a date. 2. Then we call `mean()` which because of `super()` will call the `mean()` method we defined above. 3. Finally, we take the number returned by mean and convert it back to a date. If you're very familiar with S3 or S4 you might recognize that `super()` fills a similar role to `NextMethod()` or `callNextMethod()`. However, it's much more explicit: you need to supply the name of the parent class, the generic to use, and all the arguments to the generic. This explicitness makes the code easier to understand and will eventually enable certain performance optimizations that would otherwise be very difficult. ## Multiple dispatch So far we have focused primarily on single dispatch, i.e. generics where `dispatch_on` is a single string. It is also possible to supply a length 2 (or more!) vector `dispatch_on` to create a generic that performs multiple dispatch, i.e. it uses the classes of more than one object to find the appropriate method. Multiple dispatch is a feature primarily of S4, although S3 includes some limited special cases for arithmetic operators. Multiple dispatch is heavily used in S4; we don't expect it to be heavily used in S7, but it is occasionally useful. ### A simple example Let's take our speak example from `vignette("S7")` and extend it to teach our pets how to speak multiple languages: ```{r} Pet <- new_class("Pet") Dog <- new_class("Dog", Pet) Cat <- new_class("Cat", Pet) Language <- new_class("Language") English <- new_class("English", Language) French <- new_class("French", Language) speak <- new_generic("speak", c("x", "y")) method(speak, list(Dog, English)) <- function(x, y) "Woof" method(speak, list(Cat, English)) <- function(x, y) "Meow" method(speak, list(Dog, French)) <- function(x, y) "Ouaf Ouaf" method(speak, list(Cat, French)) <- function(x, y) "Miaou" speak(Cat(), English()) speak(Dog(), French()) # This example was originally inspired by blog.klipse.tech/javascript/2021/10/03/multimethod.html # which has unfortunately since disappeared. ``` ### Special "classes" There are two special classes that become particularly useful with multiple dispatch: - `class_any()` will match any class - `class_missing()` will match a missing argument (i.e. not `NA`, but an argument that was not supplied) S7/vignettes/packages.Rmd0000644000176200001440000000617514533115246015012 0ustar liggesusers--- title: "Using S7 in a package" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Using S7 in a package} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` This vignette outlines the most important things you need to know about using S7 in a package. S7 is new, so few people have used it in a package yet; this means that this vignette is likely incomplete, and we'd love your help to make it better. Please [let us know](https://github.com/RConsortium/S7/issues/new) if you have questions that this vignette doesn't answer. ```{r setup} library(S7) ``` ## Method registration You should always call `methods_register()` in your `.onLoad()`: ```{r} .onLoad <- function(...) { S7::methods_register() } ``` This is S7's way of registering methods, rather than using export directives in your `NAMESPACE` like S3 and S4 do. This is only strictly necessary if registering methods for generics in other packages, but there's no harm in adding it and it ensures that you won't forget later. (And if you're not importing S7 into your namespace it will quiet an `R CMD check` `NOTE`.`)` ## Documentation and exports If you want users to create instances of your class, you will need to export the class constructor. That means you will also need to document it, and since the constructor is a function, that means you have to document the arguments which will be the properties of the class (unless you have customised the constructor). If you export a class, you must also set the `package` argument, ensuring that classes with the same name are disambiguated across packages. You should document generics like regular functions (since they are!). If you expect others to create their own methods for your generic, you may want to include an section describing the the properties that you expect all methods to have. We plan to provide a an easy way to all methods for a generic, but have not yet implemented it. You can track progress at . We don't currently have any recommendations on documenting methods. There's no need to document them in order to pass `R CMD check`, but obviously there are cases where it's nice to provide additional details for a method, particularly if it takes extra arguments compared to the generic. We're tracking that issue at . ## Backward compatibility If you are using S7 in a package *and* you want your package to work in versions of R before 4.3.0, you need to know that in these versions of R `@` only works with S4 objects. There are two workarounds. The easiest and least convenient workaround is to just `prop()` instead of `@`. Otherwise, you can conditionally make an S7-aware `@` available to your package with this custom `NAMESPACE` directive: ``` r # enable usage of @name in package code #' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@") NULL ``` `@` will work for users of your package because S7 automatically attaches an environment containing the needed definition when it's loaded. S7/vignettes/minutes/0000755000176200001440000000000014531143062014236 5ustar liggesusersS7/vignettes/minutes/2022-08-01.Rmd0000644000176200001440000000105514527735365015755 0ustar liggesusers--- title: "Minutes 2022-08-08" --- ## Updates from Hadley * Talks at useR and rstudio::conf() appeared to go well * Has resulted in some useful issues and PRs (esp. https://github.com/jamieRowen and https://github.com/dgkf). * Interest from Merck via email ## Next steps * HW will continue to work on smaller issues. * R-core meeting in Vienna (Sept). ML to present S7 work and hopefully get some buy-in. * Base patches? (https://github.com/RConsortium/S7/issues/222) * Get to CRAN to get more exposure and figure out how to get into base R itself. S7/vignettes/minutes/2022-03-08.Rmd0000644000176200001440000000354414527735365015764 0ustar liggesusers--- title: "Minutes 2022-03-08" --- ## Changes - Website updates (): refreshed readme, minutes as articles. Working on documentation overhaul in . - `new_generic()` now requires `dispatch_args`. This means that `new_generic()` will typically be called without names: - `new_generic("foo", "x")` - `new_generic("foo", "x", function(x, y) call_method())` - New `class_any` (could already define methods for `S7_object`) and `class_missing` sentinels. - When creating an object, unspecified properties are initialized with their default value (#67). To achieve this, the constructor arguments default to `class_missing`, since `NULL` would prevent a default value of `NULL`, and `missing()` requires too many gymnastics. - `new_class("foo", properties = list(x = integer, y = double))@constructor` - - See other minor changes in\ ## Discussion - Rename `method_call()`? --- `S7_dispatch()` sounds good. - Abstract classes? . Easy to implement but is it worth it? - What should we call the S7 equivalent of inherits? --- call it `S7_inherits()` for now; will eventually just be part of inherits. Propose generic extension mechanism for inherits. - Explicit S4 registration: - New names for base types? --- `class_` sounds good. - Convert and super: - Should we offer encapsulated OO? S7/vignettes/minutes/2022-02-12.Rmd0000644000176200001440000000551514527735365015756 0ustar liggesusers--- title: "Minutes 2022-02-12" --- ## Process check-in Minor stuff I'm just doing. Bigger changes I get Davis to review. No semantic changes without discussion in issues ## Changes - Non S7 classes - `as_class()` centralises all handling of classes (base types, S3, S4, and S7) - Strings now only refer to base types (previously used for S3 + S7 class in parent frame) `new_class( parent = "function")` - Numeric, atomic, and vector "types" as S7 unions. - Should we provide some wrappers to base unions and consider if we could get rid of string representation altogether? (e.g. `base_atomic`) - New `s3_class()` to define S3 classes. - makes it possible for S7 class to extend an S3 class - Should we export the S3 class definitions for common base S3 classes? And then provide with `base_factor` etc. - S4 unions converted to S7 unions - Method registration - Clarify difference between registration and dispatch. Will flow into refactoring of C code in near future. - Dispatch is base/S3/S4/S7 class with S7 generic. - Registration is base/S3/S4/S7 class with S7 generic AND S7 class with S3/S4 generic. - All combinations now tested. - Thorough refactoring of method registration - Method dispatch - In generic, `signature` -> `dispatch_args`. - Simplified evaluation and restricted dispatch args (probably too much, but we relax as needed) - Should we provide a default dispatch argument name? `x` - Validation - Validate types, then call `validator()` - Also call `validator()` for all super classes - New `props<-` for multi-assignment. Only validates at end. - General QoL improvements to `print()` and `str()` methods ## Next up - Refactor method dispatch - Defaults for properties, to get to point where `constructor()` without any argument usually works - Dispatch on Missing/Any - Coercion (`cast()`) - Eliminate `next_method()` (`up_cast()`) - Documentation ## Discussion - Speak about at rstudio::conf or useR? - Still need a real world application - Hadley to submit proposals to useR + rstudio::conf; and determine speakers and topics closer to the time - Next time we meet, we should discuss other ways to advertise - Ok to rename default branch from master to main? \~5 minutes work and unlikely to cause any problems. - Ok to eliminate `prop_safely()`? - Convention for displaying class names: / - Only show for S3/S4 - Name of sentinel for missing/any dispatch: - `_arg` looks good - Coercion: S7/vignettes/minutes/2021-05-18.Rmd0000644000176200001440000000461714527735365015770 0ustar liggesusers--- title: "Minutes 2021-05-18" --- **Present**: Michael Lawrence (chair), Hong Ooi, Luke Tierney, Hadley Wickham, Will Landau, Henrik Bengtsson ## Discussion ### Process (ML) - Active discussion in GitHub issues: - Need a little process to finalise discussion. Proposal: original author reads discussion, summarises, and creates a pull request that closes the issue. Any participants in the discussion should be added as reviewers. - Once issues are resolved, we can start to move forward on next steps for syntax, implementation, ... ### Do you have a sense for what the system might look like? (HB) - Unfortunately don't have a lot of time, but reading and happy to review. how much of an implementation do you have in your head? - **ML**: Quite a bit; but wanted to make sure to step back and make sure we have all the requirements. But yes, have some vision in my head. - **HW**: Have some clear idea in my head; mostly building on top of S3 ### Would it look more like S3, S4, or something completely new? (HB) - **ML**: one of the main restrictions is to build off existing system - **HW**: one of the advantages is NAMESPACE - **ML**: and that base uses - **LT**: want to be able to define new methods for "[", which means has to be maximally compatible with base. ### Double dispatch (HW/LT) - **LT**: no double dispatch in S3. S4 overly ambitious and v hard to maintain. CLOS written be v. smart people and still got things wrong. - **HW**: may need to carve double dispatch into v2. - **HO**: multiple inheritance is falling out of favour (diamond inheritance problem etc). Could we use interface based approach instead? ### Generic "interfaces" (LT) - **LT**: need to consider not just generics by themselves, but how they are related. - Related to contracts in Eiffel, concepts in C++20, \... ### Message passing OOP (HO) - **HO**: should we be considering this? (i.e. R6 and ref classes) - **ML**: currently out of scope ### What are the implications for compiling? (HB) - **LT:** compiling currently entirely within functions; one day might be nice to compile across functions/methods etc. Always thinking about how compilation might work. But generally features that are hard to compile are hard for users to understand. ## Action items - Continue discussion in issues - Start turning issues into PRs - Feel free to fix minor issues S7/vignettes/minutes/2022-09-12.Rmd0000644000176200001440000000020014455512357015741 0ustar liggesusers--- title: "Minutes 2022-09-12" --- * ML to present at R-core Vienna meeting next week. * Not much activity on GitHub lately. S7/vignettes/motivation.Rmd0000644000176200001440000001131314533115246015413 0ustar liggesusers--- title: "Motivation for S7" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Motivation for S7} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` R already has two OO systems built-in (S3 and S4) and many additional OO systems are available in CRAN packages. Why did we decide more work was needed? This vignette will discuss some of the motivations behind S7, focussing on the aspects of S3 and S4 that have been found to be particularly challenging in practice. ```{r setup} library(S7) ``` ## Challenges with S3 - S3 is very informal, meaning that there's no formal definition of a class. This makes it impossible to know exactly which properties an object should or could possess, or even what its parent class should be. S7 resolves this problem with a formal definition encoded in a class object produced by `new_class()`. This includes support for validation (and avoiding validation where needed) as inspired by S4. - When a new user encounter an S3 generic, they are often confused because the implementation of the function appears to be missing. S7 has a thoughtfully designed print method that makes it clear what methods are available and how to find their source code. - Properties of an S3 class are usually stored in attributes, but, by default, `attr()` does partial matching, which can lead to bugs that are hard to diagnose. Additionally, `attr()` returns `NULL` if an attribute doesn't exist, so misspelling an attribute can lead to subtle bugs. `@` fixes both of these problems. - S3 method dispatch is complicated for compatibility with S. This complexity affects relatively little code, but when you attempt to dive into the details it makes `UseMethod()` hard to understand. As much as possible, S7 avoids any "funny" business with environments or promises, so that there is no distinction between argument values and local values. - S3 is primarily designed for single dispatch and double dispatch is only provided for a handful of base generics. It's not possible to reuse the implementation for user generics. S7 provides a standard way of doing multiple dispatch (including double dispatch) that can be used for any generic. - `NextMethod()` is unpredictable since you can't tell exactly which method will be called by only reading the code; you instead need to know both the complete class hierarchy and what other methods are currently registered (and loading a package might change those methods). S7 takes a difference approach with `super()`, requiring explicit specification of the superclass to be used. - Conversion between S3 classes is only implemented via loose convention: if you implement a class `foo`, then you should also provide generic `as.foo()` to convert other objects to that type. S7 avoids this problem by providing the double-dispatch `convert()` generic so that you only need to provide the appropriate methods. ## Challenges with S4 - Multiple inheritance seemed like a powerful idea at the time, but in practice it appears to generate more problems than it solves. S7 does not support multiple inheritance. - S4's method dispatch uses a principled but complex distance metric to pick the best method in the presence of ambiguity. Time has shown that this approach is hard for people to understand and makes it hard to predict what will happen when new methods are registered. S7 implements a much simpler, greedy, approach that trades some additional work on behalf of the class author for a system that is simpler and easier to understand. - S4 is a clean break from S3. This made it possible to make radical changes but it made it harder to switch from S3 to S4, leading to a general lack of adoption in the R community. S7 is designed to be drop-in compatible with S3, making it possible to convert existing packages to use S7 instead of S3 with only an hour or two of work. - At least within Bioconductor, slots are generally thought of as implementation detail that should not be directly accessed by the end-user. This leads to two problems. Firstly, implementing an S4 Bioconductor class often also requires a plethora of accessor functions that are a thin wrapper around `@` or `@<-`. Secondly, users know about `@` and use it to access object internals even though they're not supposed to. S7 avoids these problems by accepting the fact that R is a data language, and that there's no way to stop users from pulling the data they need out of an object. To make it possible to change the internal implementation details of an object while preserving existing `@` usage, S7 provides dynamic properties. S7/vignettes/S7.Rmd0000644000176200001440000001337114712423107013516 0ustar liggesusers--- title: "S7 basics" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{S7 basics} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` The S7 package provides a new OOP system designed to be a successor to S3 and S4. It has been designed and implemented collaboratively by the RConsortium Object-Oriented Programming Working Group, which includes representatives from R-Core, BioConductor, RStudio/tidyverse, and the wider R community. This vignette gives an overview of the most important parts of S7: classes and objects, generics and methods, and the basics of method dispatch and inheritance. ```{r setup} library(S7) ``` ## Classes and objects S7 classes have a formal definition that you create with `new_class()`. There are two arguments that you'll use with almost every class: - The `name` of the class, supplied in the first argument. - The class `properties`, the data associated with each instance of the class. The easiest way to define properties is to supply a named list where the values define the valid types of the property. The following code defines a simple `dog` class with two properties: a character `name` and a numeric `age`. ```{r} Dog <- new_class("Dog", properties = list( name = class_character, age = class_numeric )) Dog ``` S7 provides a number of built-in definitions that allow you to refer to existing base types that are not S7 classes. You can recognize these definitions because they all start with `class_`. Note that I've assigned the return value of `new_class()` to an object with the same name as the class. This is important! That object represents the class and is what you use to construct instances of the class: ```{r} lola <- Dog(name = "Lola", age = 11) lola ``` Once you have an S7 object, you can get and set properties using `@`: ```{r} lola@age <- 12 lola@age ``` S7 automatically validates the type of the property using the type supplied in `new_class()`: ```{r, error = TRUE} lola@age <- "twelve" ``` Given an object, you can retrieves its class `S7_class()`: ```{r} S7_class(lola) ``` S7 objects also have an S3 `class()`. This is used for compatibility with existing S3 generics and you can learn more about it in `vignette("compatibility")`. ```{r} class(lola) ``` If you want to learn more about the details of S7 classes and objects, including validation methods and more details of properties, please see `vignette("classes-objects")`. ## Generics and methods S7, like S3 and S4, is built around the idea of **generic functions,** or **generics** for short. A generic defines an interface, which uses a different implementation depending on the class of one or more arguments. The implementation for a specific class is called a **method**, and the generic finds that appropriate method by performing **method dispatch**. Use `new_generic()` to create a S7 generic. In its simplest form, it only needs two arguments: the name of the generic (used in error messages) and the name of the argument used for method dispatch: ```{r} speak <- new_generic("speak", "x") ``` Like with `new_class()`, you should always assign the result of `new_generic()` to a variable with the same name as the first argument. Once you have a generic, you can register methods for specific classes with `method(generic, class) <- implementation`. ```{r} method(speak, Dog) <- function(x) { "Woof" } ``` Once the method is registered, the generic will use it when appropriate: ```{r} speak(lola) ``` Let's define another class, this one for cats, and define another method for `speak()`: ```{r} Cat <- new_class("Cat", properties = list( name = class_character, age = class_double )) method(speak, Cat) <- function(x) { "Meow" } fluffy <- Cat(name = "Fluffy", age = 5) speak(fluffy) ``` You get an error if you call the generic with a class that doesn't have a method: ```{r, error = TRUE} speak(1) ``` ## Method dispatch and inheritance The `cat` and `dog` classes share the same properties, so we could use a common parent class to extract out the duplicated specification. We first define the parent class: ```{r} Pet <- new_class("Pet", properties = list( name = class_character, age = class_numeric ) ) ``` Then use the `parent` argument to `new_class:` ```{r} Cat <- new_class("Cat", parent = Pet) Dog <- new_class("Dog", parent = Pet) Cat Dog ``` Because we have created new classes, we need to recreate the existing `lola` and `fluffy` objects: ```{r} lola <- Dog(name = "Lola", age = 11) fluffy <- Cat(name = "Fluffy", age = 5) ``` Method dispatch takes advantage of the hierarchy of parent classes: if a method is not defined for a class, it will try the method for the parent class, and so on until it finds a method or gives up with an error. This inheritance is a powerful mechanism for sharing code across classes. ```{r} describe <- new_generic("describe", "x") method(describe, Pet) <- function(x) { paste0(x@name, " is ", x@age, " years old") } describe(lola) describe(fluffy) method(describe, Dog) <- function(x) { paste0(x@name, " is a ", x@age, " year old dog") } describe(lola) describe(fluffy) ``` You can define a fallback method for any S7 object by registering a method for `S7_object`: ```{r} method(describe, S7_object) <- function(x) { "An S7 object" } Cocktail <- new_class("Cocktail", properties = list( ingredients = class_character ) ) martini <- Cocktail(ingredients = c("gin", "vermouth")) describe(martini) ``` Printing a generic will show you which methods are currently defined: ```{r} describe ``` And you can use `method()` to retrieve the implementation of one of those methods: ```{r} method(describe, Pet) ``` Learn more about method dispatch in `vignette("generics-methods")`. S7/vignettes/performance.Rmd0000644000176200001440000001131614712423107015523 0ustar liggesusers--- title: "Performance" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Performance} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(S7) ``` The dispatch performance should be roughly on par with S3 and S4, though as this is implemented in a package there is some overhead due to `.Call` vs `.Primitive`. ```{r performance, cache = FALSE} Text <- new_class("Text", parent = class_character) Number <- new_class("Number", parent = class_double) x <- Text("hi") y <- Number(1) foo_S7 <- new_generic("foo_S7", "x") method(foo_S7, Text) <- function(x, ...) paste0(x, "-foo") foo_S3 <- function(x, ...) { UseMethod("foo_S3") } foo_S3.Text <- function(x, ...) { paste0(x, "-foo") } library(methods) setOldClass(c("Number", "numeric", "S7_object")) setOldClass(c("Text", "character", "S7_object")) setGeneric("foo_S4", function(x, ...) standardGeneric("foo_S4")) setMethod("foo_S4", c("Text"), function(x, ...) paste0(x, "-foo")) # Measure performance of single dispatch bench::mark(foo_S7(x), foo_S3(x), foo_S4(x)) bar_S7 <- new_generic("bar_S7", c("x", "y")) method(bar_S7, list(Text, Number)) <- function(x, y, ...) paste0(x, "-", y, "-bar") setGeneric("bar_S4", function(x, y, ...) standardGeneric("bar_S4")) setMethod("bar_S4", c("Text", "Number"), function(x, y, ...) paste0(x, "-", y, "-bar")) # Measure performance of double dispatch bench::mark(bar_S7(x, y), bar_S4(x, y)) ``` A potential optimization is caching based on the class names, but lookup should be fast without this. The following benchmark generates a class hierarchy of different levels and lengths of class names and compares the time to dispatch on the first class in the hierarchy vs the time to dispatch on the last class. We find that even in very extreme cases (e.g. 100 deep hierarchy 100 of character class names) the overhead is reasonable, and for more reasonable cases (e.g. 10 deep hierarchy of 15 character class names) the overhead is basically negligible. ```{r performance-2, message = FALSE, R.options = list(width = 120), cache = TRUE} library(S7) gen_character <- function (n, min = 5, max = 25, values = c(letters, LETTERS, 0:9)) { lengths <- sample(min:max, replace = TRUE, size = n) values <- sample(values, sum(lengths), replace = TRUE) starts <- c(1, cumsum(lengths)[-n] + 1) ends <- cumsum(lengths) mapply(function(start, end) paste0(values[start:end], collapse=""), starts, ends) } bench::press( num_classes = c(3, 5, 10, 50, 100), class_nchar = c(15, 100), { # Construct a class hierarchy with that number of classes Text <- new_class("Text", parent = class_character) parent <- Text classes <- gen_character(num_classes, min = class_nchar, max = class_nchar) env <- new.env() for (x in classes) { assign(x, new_class(x, parent = parent), env) parent <- get(x, env) } # Get the last defined class cls <- parent # Construct an object of that class x <- do.call(cls, list("hi")) # Define a generic and a method for the last class (best case scenario) foo_S7 <- new_generic("foo_S7", "x") method(foo_S7, cls) <- function(x, ...) paste0(x, "-foo") # Define a generic and a method for the first class (worst case scenario) foo2_S7 <- new_generic("foo2_S7", "x") method(foo2_S7, S7_object) <- function(x, ...) paste0(x, "-foo") bench::mark( best = foo_S7(x), worst = foo2_S7(x) ) } ) ``` And the same benchmark using double-dispatch ```{r performance-3, message = FALSE, R.options = list(width = 120), cache = TRUE} bench::press( num_classes = c(3, 5, 10, 50, 100), class_nchar = c(15, 100), { # Construct a class hierarchy with that number of classes Text <- new_class("Text", parent = class_character) parent <- Text classes <- gen_character(num_classes, min = class_nchar, max = class_nchar) env <- new.env() for (x in classes) { assign(x, new_class(x, parent = parent), env) parent <- get(x, env) } # Get the last defined class cls <- parent # Construct an object of that class x <- do.call(cls, list("hi")) y <- do.call(cls, list("ho")) # Define a generic and a method for the last class (best case scenario) foo_S7 <- new_generic("foo_S7", c("x", "y")) method(foo_S7, list(cls, cls)) <- function(x, y, ...) paste0(x, y, "-foo") # Define a generic and a method for the first class (worst case scenario) foo2_S7 <- new_generic("foo2_S7", c("x", "y")) method(foo2_S7, list(S7_object, S7_object)) <- function(x, y, ...) paste0(x, y, "-foo") bench::mark( best = foo_S7(x, y), worst = foo2_S7(x, y) ) } ) ``` S7/vignettes/classes-objects.Rmd0000644000176200001440000002461314712423107016312 0ustar liggesusers--- title: "Classes and objects" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Classes and objects} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` This vignette dives into the details of S7 classes and objects, building on the basics discussed in `vignette("S7")`. It will cover validators, the finer details of properties, and finally how to write your own constructors. ```{r setup} library(S7) ``` ## Validation S7 classes can have an optional **validator** that checks that the values of the properties are OK. A validator is a function that takes the object (called `self`) and returns `NULL` if its valid or returns a character vector listing the problems. ### Basics In the following example we create a `Range` class that enforces that `@start` and `@end` are single numbers, and that `@start` is less than `@end`: ```{r} Range <- new_class("Range", properties = list( start = class_double, end = class_double ), validator = function(self) { if (length(self@start) != 1) { "@start must be length 1" } else if (length(self@end) != 1) { "@end must be length 1" } else if (self@end < self@start) { sprintf( "@end (%i) must be greater than or equal to @start (%i)", self@end, self@start ) } } ) ``` You can typically write a validator as a series of `if`-`else` statements, but note that the order of the statements is important. For example, in the code above, we can't check that `self@end < self@start` before we've checked that `@start` and `@end` are length 1. As we'll discuss shortly, you can also perform validation on a per-property basis, so generally class validators should be reserved for interactions between properties. ### When is validation performed? Objects are validated automatically when constructed and when any property is modified: ```{r, error = TRUE} x <- Range(1, 2:3) x <- Range(10, 1) x <- Range(1, 10) x@start <- 20 ``` You can also manually `validate()` an object if you use a low-level R function to bypass the usual checks and balances of `@`: ```{r, error = TRUE} x <- Range(1, 2) attr(x, "start") <- 3 validate(x) ``` ### Avoiding validation Imagine you wanted to write a function that would shift a property to the left or the right: ```{r} shift <- function(x, shift) { x@start <- x@start + shift x@end <- x@end + shift x } shift(Range(1, 10), 1) ``` There's a problem if `shift` is larger than `@end` - `@start`: ```{r, error = TRUE} shift(Range(1, 10), 10) ``` While the end result of `shift()` will be valid, an intermediate state is not. The easiest way to resolve this problem is to set the properties all at once: ```{r} shift <- function(x, shift) { props(x) <- list( start = x@start + shift, end = x@end + shift ) x } shift(Range(1, 10), 10) ``` The object is still validated, but it's only validated once, after all the properties have been modified. ## Properties So far we've focused on the simplest form of property specification where you use a named list to supply the desired type for each property. This is a convenient shorthand for a call to `new_property()`. For example, the property definition of range above is shorthand for: ```{r} Range <- new_class("Range", properties = list( start = new_property(class_double), end = new_property(class_double) ) ) ``` Calling `new_property()` explicitly allows you to control aspects of the property other than its type. The following sections show you how to add a validator, provide a default value, compute the property value on demand, or provide a fully dynamic property. ### Validation You can optionally provide a validator for each property. For example, instead of validating the length of `start` and `end` in the validator of our `Range` class, we could implement those at the property level: ```{r, error = TRUE} prop_number <- new_property( class = class_double, validator = function(value) { if (length(value) != 1L) "must be length 1" } ) Range <- new_class("Range", properties = list( start = prop_number, end = prop_number ), validator = function(self) { if (self@end < self@start) { sprintf( "@end (%i) must be greater than or equal to @start (%i)", self@end, self@start ) } } ) Range(start = c(1.5, 3.5)) Range(end = c(1.5, 3.5)) ``` Note that property validators shouldn't include the name of the property in validation messages as S7 will add it automatically. This makes it possible to use the same property definition for multiple properties of the same type, as above. ### Default value The defaults of `new_class()` create an class that can be constructed with no arguments: ```{r} Empty <- new_class("Empty", properties = list( x = class_double, y = class_character, z = class_logical )) Empty() ``` The default values of the properties will be filled in with "empty" instances. You can instead provide your own defaults by using the `default` argument: ```{r} Empty <- new_class("Empty", properties = list( x = new_property(class_numeric, default = 0), y = new_property(class_character, default = ""), z = new_property(class_logical, default = NA) ) ) Empty() ``` A quoted call becomes a standard function promise in the default constructor, evaluated at the time the object is constructed. ```{r} Stopwatch <- new_class("Stopwatch", properties = list( start_time = new_property( class = class_POSIXct, default = quote(Sys.time()) ), elapsed = new_property( getter = function(self) { difftime(Sys.time(), self@start_time, units = "secs") } ) )) args(Stopwatch) round(Stopwatch()@elapsed) round(Stopwatch(Sys.time() - 1)@elapsed) ``` ### Computed properties It's sometimes useful to have a property that is computed on demand. For example, it'd be convenient to pretend that our range has a length, which is just the distance between `@start` and `@end`. You can dynamically compute the value of a property by defining a `getter`: ```{r} Range <- new_class("Range", properties = list( start = class_double, end = class_double, length = new_property( getter = function(self) self@end - self@start, ) ) ) x <- Range(start = 1, end = 10) x ``` Computed properties are read-only: ```{r, error = TRUE} x@length <- 20 ``` ### Dynamic properties You can make a computed property fully dynamic so that it can be read and written by also supplying a `setter`. A `setter` is a function with arguments `self` and `value` that returns a modified object. For example, we could extend the previous example to allow the `@length` to be set, by modifying the `@end` of the vector: ```{r} Range <- new_class("Range", properties = list( start = class_double, end = class_double, length = new_property( class = class_double, getter = function(self) self@end - self@start, setter = function(self, value) { self@end <- self@start + value self } ) ) ) x <- Range(start = 1, end = 10) x x@length <- 5 x ``` ### Common Patterns `getter`, `setter`, `default`, and `validator` can be used to implement many common patterns of properties. #### Deprecated properties A `setter` + `getter` can be used to to deprecate a property: ```{r} Person <- new_class("Person", properties = list( first_name = class_character, firstName = new_property( class_character, default = quote(first_name), getter = function(self) { warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) self@first_name }, setter = function(self, value) { if (identical(value, self@first_name)) { return(self) } warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) self@first_name <- value self } ) )) args(Person) hadley <- Person(firstName = "Hadley") hadley <- Person(first_name = "Hadley") # no warning hadley@firstName hadley@firstName <- "John" hadley@first_name # no warning ``` #### Required properties You can make a property required by the constructor either by: - relying on the validator to error with the default value, or by - setting the property default to a quoted error call. ```{r} Person <- new_class("Person", properties = list( name = new_property( class_character, validator = function(value) { if (length(value) != 1 || is.na(value) || value == "") "must be a non-empty string" } ) )) try(Person()) try(Person(1)) # class_character$validator() is also checked. Person("Alice") ``` ```{r} Person <- new_class("Person", properties = list( name = new_property( class_character, default = quote(stop("@name is required"))) )) try(Person()) Person("Alice") ``` #### Frozen properties You can mark a property as read-only after construction by providing a custom `setter`. ```{r} Person <- new_class("Person", properties = list( birth_date = new_property( class_Date, setter = function(self, value) { if(!is.null(self@birth_date)) { stop("@birth_date is read-only", call. = FALSE) } self@birth_date <- as.Date(value) self } ))) person <- Person("1999-12-31") try(person@birth_date <- "2000-01-01") ``` ## Constructors You can see the source code for a class's constructor by accessing the `constructor` property: ```{r} Range@constructor ``` In most cases, S7's default constructor will be all you need. However, in some cases you might want something custom. For example, for our range class, maybe we'd like to construct it from a vector of numeric values, automatically computing the min and the max. To implement this we could do: ```{r} Range <- new_class("Range", properties = list( start = class_numeric, end = class_numeric ), constructor = function(x) { new_object(S7_object(), start = min(x, na.rm = TRUE), end = max(x, na.rm = TRUE)) } ) range(c(10, 5, 0, 2, 5, 7)) ``` A constructor must always end with a call to `new_object()`. The first argument to `new_object()` should be an object of the `parent` class (if you haven't specified a `parent` argument to `new_class()`, then you should use `S7_object()` as the parent here). That argument should be followed by one named argument for each property. There's one drawback of custom constructors that you should be aware of: any subclass will also require a custom constructor. S7/src/0000755000176200001440000000000014712722347011343 5ustar liggesusersS7/src/prop.c0000644000176200001440000002607514712423107012471 0ustar liggesusers#define R_NO_REMAP #include #include extern SEXP sym_S7_class; extern SEXP sym_name; extern SEXP sym_parent; extern SEXP sym_package; extern SEXP sym_properties; extern SEXP sym_abstract; extern SEXP sym_constructor; extern SEXP sym_validator; extern SEXP ns_S7; extern SEXP sym_dot_should_validate; extern SEXP sym_dot_getting_prop; extern SEXP sym_dot_setting_prop; extern SEXP fn_base_quote; static inline SEXP eval_here(SEXP lang) { PROTECT(lang); SEXP ans = Rf_eval(lang, ns_S7); UNPROTECT(1); return ans; } static inline SEXP do_call1(SEXP fn, SEXP arg) { SEXP call, answer; switch (TYPEOF(arg)) { case LANGSXP: case SYMSXP: arg = PROTECT(Rf_lang2(fn_base_quote, arg)); call = PROTECT(Rf_lang2(fn, arg)); answer = Rf_eval(call, ns_S7); UNPROTECT(2); return answer; default: call = PROTECT(Rf_lang2(fn, arg)); answer = Rf_eval(call, ns_S7); UNPROTECT(1); return answer; } } static inline SEXP do_call2(SEXP fn, SEXP arg1, SEXP arg2) { int n_protected = 0; // Protect the arguments from evaluation if they are SYMSXP or LANGSXP switch (TYPEOF(arg1)) { case LANGSXP: case SYMSXP: arg1 = PROTECT(Rf_lang2(fn_base_quote, arg1)); ++n_protected; } switch (TYPEOF(arg2)) { case LANGSXP: case SYMSXP: arg2 = PROTECT(Rf_lang2(fn_base_quote, arg2)); ++n_protected; } SEXP call = PROTECT(Rf_lang3(fn, arg1, arg2)); ++n_protected; SEXP result = Rf_eval(call, ns_S7); UNPROTECT(n_protected); return result; } static __attribute__((noreturn)) void signal_is_not_S7(SEXP object) { static SEXP check_is_S7 = NULL; if (check_is_S7 == NULL) check_is_S7 = Rf_findVarInFrame(ns_S7, Rf_install("check_is_S7")); // will signal error eval_here(Rf_lang2(check_is_S7, object)); while(1); } static __attribute__((noreturn)) void signal_prop_error(const char* fmt, SEXP object, SEXP name) { static SEXP signal_prop_error = NULL; if (signal_prop_error == NULL) signal_prop_error = Rf_findVarInFrame(ns_S7, Rf_install("signal_prop_error")); eval_here(Rf_lang4(signal_prop_error, Rf_mkString(fmt), object, name)); while(1); } static __attribute__((noreturn)) void signal_prop_error_unknown(SEXP object, SEXP name) { signal_prop_error("Can't find property %s@%s", object, name); } static __attribute__((noreturn)) void signal_error(SEXP errmsg) { PROTECT(errmsg); if(TYPEOF(errmsg) == STRSXP && Rf_length(errmsg) == 1) Rf_errorcall(R_NilValue, "%s", CHAR(STRING_ELT(errmsg, 0))); // fallback to calling base::stop(errmsg) static SEXP signal_error = NULL; if (signal_error == NULL) signal_error = Rf_findVarInFrame(ns_S7, Rf_install("signal_error")); eval_here(Rf_lang2(signal_error, errmsg)); while(1); } static inline int name_idx(SEXP list, const char* name) { SEXP names = Rf_getAttrib(list, R_NamesSymbol); if (TYPEOF(names) == STRSXP) { for (int i = 0, n = Rf_length(names); i < n; i++) { if (strcmp(CHAR(STRING_ELT(names, i)), name) == 0) return i; } } return -1; } static inline SEXP extract_name(SEXP list, const char* name) { int i = name_idx(list, name); return i == -1 ? R_NilValue : VECTOR_ELT(list, i); } static inline Rboolean inherits2(SEXP object, const char* name) { // like inherits in R, but iterates over the class STRSXP vector // in reverse, since S7_* is typically at the tail. SEXP klass = Rf_getAttrib(object, R_ClassSymbol); if (TYPEOF(klass) == STRSXP) { for (int i = Rf_length(klass)-1; i >= 0; i--) { if (strcmp(CHAR(STRING_ELT(klass, i)), name) == 0) return TRUE; } } return FALSE; } static inline Rboolean is_s7_object(SEXP object) { return inherits2(object, "S7_object"); } static inline Rboolean is_s7_class(SEXP object) { return inherits2(object, "S7_class"); } static inline void check_is_S7(SEXP object) { if (is_s7_object(object)) return; signal_is_not_S7(object); } static inline Rboolean pairlist_contains(SEXP list, SEXP elem) { for (SEXP c = list; c != R_NilValue; c = CDR(c)) if (CAR(c) == elem) return TRUE; return FALSE; } static inline SEXP pairlist_remove(SEXP list, SEXP elem) { SEXP c0 = NULL, head = list; for (SEXP c = list; c != R_NilValue; c0 = c, c = CDR(c)) if (CAR(c) == elem) { if (c0 == NULL) return CDR(c); else { SETCDR(c0, CDR(c)); return head; } } Rf_error("Tried to remove non-existent element from pairlist"); return R_NilValue; } static inline Rboolean setter_callable_no_recurse(SEXP setter, SEXP object, SEXP name_sym, Rboolean* should_validate_obj) { // Check if we should call `setter` and if so, prepare `setter` for calling. SEXP no_recurse_list = Rf_getAttrib(object, sym_dot_setting_prop); if (TYPEOF(no_recurse_list) == LISTSXP) { // if there is a 'no_recurse' list, then this is not the top-most prop<- // call for this object, i.e, we're currently evaluating a `prop<-` call // called from within a custom property setter. We should only call // validate(object) once from the top-most prop<- call, after the last // custom setter() has returned. *should_validate_obj = FALSE; if (pairlist_contains(no_recurse_list, name_sym)) return FALSE; } if (TYPEOF(setter) != CLOSXP) return FALSE; // setter not callable Rf_setAttrib(object, sym_dot_setting_prop, Rf_cons(name_sym, no_recurse_list)); return TRUE; // object is now now marked non-recursive for this property setter, safe to call // optimization opportunity: combine the actions of getAttrib()/setAttrib() // into one loop, so we can avoid iterating over ATTRIB(object) twice. } static inline void accessor_no_recurse_clear(SEXP object, SEXP name_sym, SEXP no_recurse_list_sym) { SEXP list = Rf_getAttrib(object, no_recurse_list_sym); list = pairlist_remove(list, name_sym); Rf_setAttrib(object, no_recurse_list_sym, list); // optimization opportunity: same as setter_callable_no_recurse } #define getter_no_recurse_clear(...) \ accessor_no_recurse_clear(__VA_ARGS__, sym_dot_getting_prop) #define setter_no_recurse_clear(...) \ accessor_no_recurse_clear(__VA_ARGS__, sym_dot_setting_prop) static inline void prop_validate(SEXP property, SEXP value, SEXP object) { static SEXP prop_validate = NULL; if (prop_validate == NULL) prop_validate = Rf_findVarInFrame(ns_S7, Rf_install("prop_validate")); SEXP errmsg = eval_here(Rf_lang4(prop_validate, property, value, object)); if (errmsg != R_NilValue) signal_error(errmsg); } static inline void obj_validate(SEXP object) { static SEXP validate = NULL; if (validate == NULL) validate = Rf_findVarInFrame(ns_S7, Rf_install("validate")); switch (TYPEOF(object)) { case LANGSXP: case SYMSXP: { // Wrap the call or symbol in quote(), so it doesn't evaluate in Rf_eval() object = PROTECT(Rf_lang2(fn_base_quote, object)); eval_here(Rf_lang4(validate, object, /* recursive = */ Rf_ScalarLogical(TRUE), /* properties = */ Rf_ScalarLogical(FALSE))); UNPROTECT(1); // object return; } default: eval_here(Rf_lang4( validate, object, /* recursive = */ Rf_ScalarLogical(TRUE), /* properties = */ Rf_ScalarLogical(FALSE))); } } static inline Rboolean getter_callable_no_recurse(SEXP getter, SEXP object, SEXP name_sym) { // Check if we should call getter and if so, prepare object for calling the getter. SEXP no_recurse_list = Rf_getAttrib(object, sym_dot_getting_prop); if (TYPEOF(no_recurse_list) == LISTSXP && pairlist_contains(no_recurse_list, name_sym)) return FALSE; Rf_setAttrib(object, sym_dot_getting_prop, Rf_cons(name_sym, no_recurse_list)); return TRUE; // object is now now marked non-recursive for this property accessor, safe to call // optimization opportunity: combine the actions of getAttrib()/setAttrib() // into one loop, so we can avoid iterating over ATTRIB(object) twice. } SEXP prop_(SEXP object, SEXP name) { check_is_S7(object); SEXP name_rchar = STRING_ELT(name, 0); const char* name_char = CHAR(name_rchar); SEXP name_sym = Rf_installTrChar(name_rchar); SEXP S7_class = Rf_getAttrib(object, sym_S7_class); SEXP properties = Rf_getAttrib(S7_class, sym_properties); // try getter() if appropriate SEXP property = extract_name(properties, name_char); SEXP getter = extract_name(property, "getter"); if (TYPEOF(getter) == CLOSXP && getter_callable_no_recurse(getter, object, name_sym)) { SEXP value = PROTECT(do_call1(getter, object)); getter_no_recurse_clear(object, name_sym); UNPROTECT(1); // value return value; } // try to resolve property from the object attributes SEXP value = Rf_getAttrib(object, name_sym); // This is commented out because we currently have no way to distinguish between // a prop with a value of NULL, and a prop value that is unset/missing. // // fall back to fetching the default property value from the object class // if (value == R_NilValue) // value = extract_name(property, "default"); // validate that we're accessing a valid property if (property != R_NilValue) return value; if (S7_class == R_NilValue && is_s7_class(object) && ( name_sym == sym_name || name_sym == sym_parent || name_sym == sym_package || name_sym == sym_properties || name_sym == sym_abstract || name_sym == sym_constructor || name_sym == sym_validator)) return value; signal_prop_error_unknown(object, name); return R_NilValue; // unreachable, for compiler } SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) { check_is_S7(object); SEXP name_rchar = STRING_ELT(name, 0); const char *name_char = CHAR(name_rchar); SEXP name_sym = Rf_installTrChar(name_rchar); Rboolean check = Rf_asLogical(check_sexp); Rboolean should_validate_obj = check; Rboolean should_validate_prop = check; SEXP S7_class = Rf_getAttrib(object, sym_S7_class); SEXP properties = Rf_getAttrib(S7_class, sym_properties); SEXP property = extract_name(properties, name_char); if (property == R_NilValue) signal_prop_error_unknown(object, name); SEXP setter = extract_name(property, "setter"); SEXP getter = extract_name(property, "getter"); if (getter != R_NilValue && setter == R_NilValue) signal_prop_error("Can't set read-only property %s@%s", object, name); PROTECT_INDEX object_pi; // maybe use R_shallow_duplicate_attr() here instead // once it becomes API or S7 becomes part of R object = Rf_shallow_duplicate(object); PROTECT_WITH_INDEX(object, &object_pi); if (setter_callable_no_recurse(setter, object, name_sym, &should_validate_obj)) { // use setter() REPROTECT(object = do_call2(setter, object, value), object_pi); setter_no_recurse_clear(object, name_sym); } else { // don't use setter() if (should_validate_prop) prop_validate(property, value, object); Rf_setAttrib(object, name_sym, value); } if (should_validate_obj) obj_validate(object); UNPROTECT(1); return object; } S7/src/init.c0000644000176200001440000000461614712423107012451 0ustar liggesusers#include #include #include // for NULL #include /* .Call calls */ extern SEXP method_(SEXP, SEXP, SEXP, SEXP); extern SEXP method_call_(SEXP, SEXP, SEXP, SEXP); extern SEXP test_call_(SEXP, SEXP, SEXP, SEXP); extern SEXP S7_class_(SEXP, SEXP); extern SEXP S7_object_(void); extern SEXP prop_(SEXP, SEXP); extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP); #define CALLDEF(name, n) {#name, (DL_FUNC) &name, n} static const R_CallMethodDef CallEntries[] = { CALLDEF(method_, 4), CALLDEF(S7_object_, 0), CALLDEF(prop_, 2), CALLDEF(prop_set_, 4), {NULL, NULL, 0} }; static const R_ExternalMethodDef ExternalEntries[] = { CALLDEF(method_call_, 2), {NULL, NULL, 0} }; SEXP sym_ANY; SEXP sym_S7_class; SEXP sym_name; SEXP sym_parent; SEXP sym_package; SEXP sym_properties; SEXP sym_abstract; SEXP sym_constructor; SEXP sym_validator; SEXP sym_getter; SEXP sym_dot_should_validate; SEXP sym_dot_getting_prop; SEXP sym_dot_setting_prop; SEXP sym_obj_dispatch; SEXP sym_dispatch_args; SEXP sym_methods; SEXP sym_S7_dispatch; SEXP sym_name; SEXP fn_base_quote; SEXP fn_base_missing; SEXP ns_S7; SEXP R_TRUE, R_FALSE; void R_init_S7(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, ExternalEntries); R_useDynamicSymbols(dll, FALSE); sym_ANY = Rf_install("ANY"); sym_S7_class = Rf_install("S7_class"); sym_name = Rf_install("name"); sym_parent = Rf_install("parent"); sym_package = Rf_install("package"); sym_properties = Rf_install("properties"); sym_abstract = Rf_install("abstract"); sym_constructor = Rf_install("constructor"); sym_validator = Rf_install("validator"); sym_getter = Rf_install("getter"); sym_dot_should_validate = Rf_install(".should_validate"); sym_dot_getting_prop = Rf_install(".getting_prop"); sym_dot_setting_prop = Rf_install(".setting_prop"); sym_obj_dispatch = Rf_install("obj_dispatch"); sym_dispatch_args = Rf_install("dispatch_args"); sym_methods = Rf_install("methods"); sym_S7_dispatch = Rf_install("S7_dispatch"); sym_name = Rf_install("name"); fn_base_quote = Rf_eval(Rf_install("quote"), R_BaseEnv); fn_base_missing = Rf_eval(Rf_install("missing"), R_BaseEnv); ns_S7 = Rf_eval(Rf_install("S7"), R_NamespaceRegistry); R_PreserveObject(R_TRUE = Rf_ScalarLogical(1)); R_PreserveObject(R_FALSE = Rf_ScalarLogical(0)); } S7/src/method-dispatch.c0000644000176200001440000002017614712423107014562 0ustar liggesusers#define R_NO_REMAP #include #include extern SEXP parent_sym; extern SEXP sym_ANY; extern SEXP ns_S7; extern SEXP sym_obj_dispatch; extern SEXP sym_dispatch_args; extern SEXP sym_methods; extern SEXP sym_S7_dispatch; extern SEXP sym_name; extern SEXP fn_base_quote; extern SEXP fn_base_missing; extern SEXP R_TRUE; static inline void APPEND_NODE(SEXP node, SEXP tag, SEXP val) { SEXP new_node = Rf_cons(val, R_NilValue); SETCDR(node, new_node); SET_TAG(new_node, tag); } // extern Rboolean is_S7_object(SEXP); // extern Rboolean is_s7_class(SEXP); // extern void check_is_S7(SEXP object); static inline SEXP maybe_enquote(SEXP x) { switch (TYPEOF(x)) { case SYMSXP: case LANGSXP: return Rf_lang2(fn_base_quote, x); default: return x; } } // Recursively walk through method table to perform iterated dispatch SEXP method_rec(SEXP table, SEXP signature, R_xlen_t signature_itr) { if (signature_itr >= Rf_xlength(signature)) { return R_NilValue; } SEXP classes = VECTOR_ELT(signature, signature_itr); for (R_xlen_t i = 0; i < Rf_xlength(classes); ++i) { SEXP klass = Rf_install(CHAR(STRING_ELT(classes, i))); SEXP val = Rf_findVarInFrame(table, klass); if (TYPEOF(val) == ENVSXP) { PROTECT(val); // no really necessary, but rchk flags spuriously val = method_rec(val, signature, signature_itr + 1); UNPROTECT(1); } if (TYPEOF(val) == CLOSXP) { return val; } } // ANY fallback SEXP val = Rf_findVarInFrame(table, sym_ANY); if (TYPEOF(val) == ENVSXP) { PROTECT(val); val = method_rec(val, signature, signature_itr + 1); UNPROTECT(1); } if (TYPEOF(val) == CLOSXP) { return val; } return R_NilValue; } SEXP generic_args(SEXP generic, SEXP envir) { // This function is only used to generate an informative message when // signalling an S7_method_lookup_error, so it doesn't need to be maximally efficient. // How many arguments are used for dispatch? SEXP dispatch_args = Rf_getAttrib(generic, sym_dispatch_args); R_xlen_t n_dispatch = Rf_xlength(dispatch_args); // Allocate a list to store the arguments SEXP args = PROTECT(Rf_allocVector(VECSXP, n_dispatch)); SEXP missing_call = PROTECT(Rf_lang2(fn_base_missing, R_NilValue)); PROTECT_INDEX pi; PROTECT_WITH_INDEX(R_NilValue, &pi); // Find the value of each argument. SEXP formals = FORMALS(generic); for (R_xlen_t i = 0; i < n_dispatch; ++i) { SEXP name = TAG(formals); SETCADR(missing_call, name); SEXP is_missing = Rf_eval(missing_call, envir); REPROTECT(is_missing, pi); if (Rf_asLogical(is_missing)) { SET_VECTOR_ELT(args, i, R_MissingArg); } else { // method_call_() has already done the necessary computation SET_VECTOR_ELT(args, i, Rf_eval(name, envir)); } formals = CDR(formals); } Rf_setAttrib(args, R_NamesSymbol, dispatch_args); UNPROTECT(3); return args; } __attribute__ ((noreturn)) void S7_method_lookup_error(SEXP generic, SEXP envir) { SEXP name = Rf_getAttrib(generic, R_NameSymbol); SEXP args = generic_args(generic, envir); SEXP S7_method_lookup_error_call = PROTECT(Rf_lang3(Rf_install("method_lookup_error"), name, args)); Rf_eval(S7_method_lookup_error_call, ns_S7); while(1); } SEXP method_(SEXP generic, SEXP signature, SEXP envir, SEXP error_) { if (!Rf_inherits(generic, "S7_generic")) { return R_NilValue; } SEXP table = Rf_getAttrib(generic, sym_methods); if (TYPEOF(table) != ENVSXP) { Rf_error("Corrupt S7_generic: @methods isn't an environment"); } SEXP m = method_rec(table, signature, 0); if (m == R_NilValue && Rf_asLogical(error_)) { S7_method_lookup_error(generic, envir); } return m; } SEXP S7_obj_dispatch(SEXP object) { SEXP obj_dispatch_call = PROTECT(Rf_lang2(sym_obj_dispatch, maybe_enquote(object))); SEXP res = Rf_eval(obj_dispatch_call, ns_S7); UNPROTECT(1); return res; } SEXP S7_object_(void) { SEXP obj = PROTECT(Rf_allocSExp(S4SXP)); Rf_classgets(obj, Rf_mkString("S7_object")); UNPROTECT(1); return obj; } SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) { args_ = CDR(args_); SEXP generic = CAR(args_); args_ = CDR(args_); SEXP envir = CAR(args_); args_ = CDR(args_); // Get the number of arguments to the 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, sym_dispatch_args); R_xlen_t n_dispatch = Rf_xlength(dispatch_args); // Allocate a list to store the classes for the arguments SEXP dispatch_classes = PROTECT(Rf_allocVector(VECSXP, n_dispatch)); // Allocate a pairlist to hold the arguments for when we call the method SEXP mcall = PROTECT(Rf_lcons(R_NilValue, R_NilValue)); SEXP mcall_tail = mcall; PROTECT_INDEX arg_pi, val_pi; PROTECT_WITH_INDEX(R_NilValue, &arg_pi); // unnecessary, for rchk only PROTECT_WITH_INDEX(R_NilValue, &val_pi); // unnecessary, for rchk only // For each of the arguments to the generic for (R_xlen_t i = 0; i < n_args; ++i) { SEXP name = TAG(formals); if (i < n_dispatch) { SEXP arg = Rf_findVarInFrame(envir, name); if (arg == R_MissingArg) { APPEND_NODE(mcall_tail, name, arg); SET_VECTOR_ELT(dispatch_classes, i, Rf_mkString("MISSING")); } else { // arg not missing, is a PROMSXP // Force the promise so we can look up its class. // However, we preserve and pass along the promise itself so that // methods can still call substitute() // Instead of Rf_eval(arg, R_EmptyEnv), we do Rf_eval(name, envir), so that // - if TYPEOF(arg) == LANGSXP or SYMSXP, arg doesn't need to be enquoted and // - if TYPEOF(arg) == PROMSXP, arg is updated in place. REPROTECT(arg, arg_pi); // unnecessary, for rchk only SEXP val = Rf_eval(name, envir); REPROTECT(val, val_pi); // unnecessary, for rchk only if (Rf_inherits(val, "S7_super")) { // Put the super() stored value into the method call. // Note: This means we don't pass along the arg PROMSXP, meaning that // substitute() in methods does not retrieve the `super()` call. // If we wanted substitute() to work here too, we could do: // if (TYPEOF(arg) == PROMSXP) { SET_PRVALUE(arg, true_val); } else { arg = true_val; } SEXP arg = VECTOR_ELT(val, 0); // true_val used for dispatch APPEND_NODE(mcall_tail, name, arg); // Put the super() stored class dispatch vector into dispatch_classes SET_VECTOR_ELT(dispatch_classes, i, VECTOR_ELT(val, 1)); } else { // val is not a S7_super, a regular value // The PROMSXP arg will have been updated in place by Rf_eval() above. // Add to arguments of method call APPEND_NODE(mcall_tail, name, arg); // Determine class string to use for method look up SET_VECTOR_ELT(dispatch_classes, i, S7_obj_dispatch(val)); } } } else { // other arguments not used for dispatch if (name == R_DotsSymbol) { SETCDR(mcall_tail, Rf_cons(R_DotsSymbol, R_NilValue)); } else { // pass along the promise so substitute() works SEXP arg = Rf_findVarInFrame(envir, name); APPEND_NODE(mcall_tail, name, arg); } } mcall_tail = CDR(mcall_tail); formals = CDR(formals); } // Now that we have all the classes, we can look up what method to call SEXP m = method_(generic, dispatch_classes, envir, R_TRUE); REPROTECT(m, val_pi); // unnecessary, for rchk only /// Inlining the method closure in the call like `SETCAR(mcall, m);` /// leads to extremely verbose (unreadable) traceback()s. So, /// for nicer tracebacks, we set a SYMSXP at the head. SEXP method_name = Rf_getAttrib(m, sym_name); if (TYPEOF(method_name) != SYMSXP) { // if name is missing, fallback to masking the `S7_dispatch` symbol. // we could alternatively fallback to inlining m: SETCAR(mcall, m) method_name = sym_S7_dispatch; } Rf_defineVar(method_name, m, envir); SETCAR(mcall, method_name); SEXP out = Rf_eval(mcall, envir); UNPROTECT(4); return out; } S7/NAMESPACE0000644000176200001440000000544414712243624011776 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$",S7_object) S3method("$<-",S7_object) S3method("@<-",S7_object) S3method("[",S7_object) S3method("[<-",S7_object) S3method("[[",S7_object) S3method("[[<-",S7_object) S3method("|",S7_class) S3method(Ops,S7_object) S3method(Ops,S7_super) S3method(c,S7_class) S3method(print,S7_S3_class) S3method(print,S7_any) S3method(print,S7_base_class) S3method(print,S7_class) S3method(print,S7_external_generic) S3method(print,S7_generic) S3method(print,S7_method) S3method(print,S7_missing) S3method(print,S7_object) S3method(print,S7_property) S3method(print,S7_super) S3method(print,S7_union) S3method(str,S7_S3_class) S3method(str,S7_any) S3method(str,S7_base_class) S3method(str,S7_class) S3method(str,S7_missing) S3method(str,S7_object) S3method(str,S7_property) S3method(str,S7_super) S3method(str,S7_union) export("S7_data<-") export("method<-") export("prop<-") export("props<-") export(S4_register) export(S7_class) export(S7_data) export(S7_dispatch) export(S7_inherits) export(S7_object) export(as_class) export(check_is_S7) export(class_Date) export(class_POSIXct) export(class_POSIXlt) export(class_POSIXt) export(class_any) export(class_atomic) export(class_call) export(class_character) export(class_complex) export(class_data.frame) export(class_double) export(class_environment) export(class_expression) export(class_factor) export(class_formula) export(class_function) export(class_integer) export(class_language) export(class_list) export(class_logical) export(class_missing) export(class_name) export(class_numeric) export(class_raw) export(class_vector) export(convert) export(method) export(method_explain) export(methods_register) export(new_S3_class) export(new_class) export(new_external_generic) export(new_generic) export(new_object) export(new_property) export(new_union) export(prop) export(prop_exists) export(prop_names) export(props) export(set_props) export(super) export(valid_eventually) export(valid_implicitly) export(validate) if (getRversion() < "4.3.0") export(`@`) if (getRversion() >= "4.3.0" && !is.null(asNamespace("utils")$.AtNames)) S3method(utils::.AtNames,S7_object) if (getRversion() >= "4.3.0") S3method(base::`@`, S7_object) if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_object) if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_super) if (getRversion() >= "4.3.0") S3method(matrixOps, S7_object) if (getRversion() >= "4.3.0") S3method(matrixOps, S7_super) if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name) if (getRversion() >= "4.3.0") S3method(nameOfClass,S7_base_class) importFrom(stats,setNames) importFrom(utils,getFromNamespace) importFrom(utils,globalVariables) importFrom(utils,hasName) importFrom(utils,head) importFrom(utils,packageName) importFrom(utils,str) useDynLib(S7, .registration = TRUE) S7/LICENSE0000644000176200001440000000005014453030452011543 0ustar liggesusersYEAR: 2023 COPYRIGHT HOLDER: S7 authors S7/NEWS.md0000644000176200001440000002002614712720505011644 0ustar liggesusers# S7 0.2.0 ## New features * The default object constructor returned by `new_class()` has been updated. It now accepts lazy (promise) property defaults and includes dynamic properties with a `setter` in the constructor. Additionally, all custom property setters are now consistently invoked by the default constructor. If you're using S7 in an R package, you'll need to re-document to ensure that your documentation matches the updated usage (#438, #445). * The call context of a dispatched method (as visible in `sys.calls()` and `traceback()`) no longer includes the inlined method and generic, resulting in more compact and readable tracebacks. The dispatched method call now contains only the method name, which serves as a hint for retrieving the method. For example: `method(my_generic, class_double)`(x=10, ...). (#486) * New `nameOfClass()` method exported for S7 base classes, to enable usage like `inherits("foo", S7::class_character)` (#432, #458) * Added support for more base/S3 classes (#434): `class_POSIXlt`, `class_POSIXt`, `class_formula`, `class_call`, `class_language`, and `class_name`. * S7 provides a new automatic backward compatibility mechanism to provide a version of `@` that works in R before version 4.3 (#326). ## Bug fixes and minor improvements * `new_class()` now automatically infers the package name when called from within an R package (#459). * Improved error message when custom validators return invalid values (#454, #457). * Fixed S3 methods registration across packages (#422). * `convert()` now provides a default method to transform a parent class instance into a subclass, enabling class construction from a prototype (#444). * A custom property `getter()` no longer infinitely recurses when accessing itself (reported in #403, fixed in #406). * `method()`generates an informative message with class `S7_error_method_not_found` when dispatch fails (#387). * `method<-()` can create multimethods that dispatch on `NULL`. * In `new_class()`, properties can either be named by naming the element of the list or by supplying the `name` argument to `new_property()` (#371). * The `Ops` generic now falls back to base Ops behaviour when one of the arguments is not an S7 object (#320). This means that you get the somewhat inconsistent base behaviour, but means that S7 doesn't introduce a new axis of inconsistency. * `prop()` (#395) and `prop<-`/`@<-` (#396) have been optimized and rewritten in C. * `super()` now works with Ops methods (#357). * `validate()` is now always called after a custom property setter was invoked (reported in #393, fixed in #396). # S7 0.1.1 * Classes get a more informative print method (#346). * Correctly register S3 methods for S7 objects with a package (#333). * External methods are now registered using an attribute of the S3 methods table rather than an element of that environment. This prevents a warning being generated during the "code/documentation mismatches" check in `R CMD check` (#342). * `class_missing` and `class_any` can now be unioned with `|` (#337). * `new_object()` no longer accepts `NULL` as `.parent`. * `new_object()` now correctly runs the validator from abstract parent classes (#329). * `new_object()` works better when custom property setters modify other properties. * `new_property()` gains a `validator` argument that allows you to specify a per-property validator (#275). * `new_property()` clarifies that it's the user's responsibility to return the correct class; it is _not_ automatically validated. * Properties with a custom setter are now validated _after_ the setter has run and are validated when the object is constructed or when you call `validate()`, not just when you modify them after construction. * `S7_inherits()` now accepts `class = NULL` to test if an object is any sort of S7 object (#347). # S7 0.1.0 ## May-July 2023 * `new_external_generic()` is only needed when you want a soft dependency on another package. * `methods_register()` now also registers S3 and S4 methods (#306). ## Jan-May 2023 * Subclasses of abstract class can have readonly properties (#269). * During construction, validation is now only performed once for each element of the class hierarchy (#248). * Implemented a better filtering strategy for the S4 class hierarchy so you can now correctly dispatch on virtual classes (#252). * New `set_props()` to make a modified copy of an object (#229). * `R CMD check` now passes on R 3.5 and greater (for tidyverse compatibility). * Dispatching on an evaluated argument no longer causes a crash (#254). * Improve method dispatch failure message (#231). * Can use `|` to create unions from S7 classes (#224). * Can no longer subclass an environment via `class_environment` because we need to think the consequences of this behaviour through more fully (#253). ## Rest of 2022 * Add `[.S7_object`, `[<-.S7_object`, `[[.S7_object`, and `[[<-.S7_object` methods to avoid "object of type 'S4' is not subsettable" error (@jamieRowen, #236). * Combining S7 classes with `c()` now gives an error (#230) * Base classes now show as `class_x` instead of `"x"` in method print (#232) ## Mar 2022 * Exported `class_factor`, `class_Date`, `class_POSIXct`, and `class_data.frame`. * New `S7_inherits()` and `check_is_S7()` (#193) * `new_class()` can create abstract classes (#199). * `method_call()` is now `S7_dispatch()` (#200). * Can now register methods for double-dispatch base Ops (currently only works if both classes are S7, or the first argument is S7 and the second doesn't have a method for the Ops generic) (#128). * All built-in wrappers around base types use `class_`. You can no longer refer to a base type with a string or a constructor function (#170). * `convert()` allows you to convert an object into another class (#136). * `super()` replaces `next_method()` (#110). ## Feb 2022 * `class_any` and `class_missing` make it possible to dispatch on absent arguments and arguments of any class (#67). * New `method_explain()` to explain dispatch (#194). * Minor property improvements: use same syntax for naming short-hand and full property specifications; input type automatically validated for custom setters. A property with a getter but no setter is read-only (#168). * When creating an object, unspecified properties are initialized with their default value (#67). DISCUSS: to achieve this, the constructor arguments default to `class_missing`. * Add `$.S7_object` and `$<-.S7_object` methods to avoid "object of type 'S4' is not subsettable" error (#204). * Dispatch now disambiguates between S4 and S3/S7, and, optionally, between S7 classes in different packages (#48, #163). * `new_generic()` now requires `dispatch_args` (#180). This means that `new_generic()` will typically be called without names. Either `new_generic("foo", "x")` for a "standard" generic, or `new_generic("foo", "x", function(x, y) call_method())` for a non-standard method. * `new_external_generic()` now requires `dispatch_args` so we can eagerly check the signature. * Revamp website. README now shows brief example and more info in `vignette("S7")`. Initial design docs and minutes are now articles so they appear on the website. ## Jan 2022 * New `props<-` for setting multiple properties simultaneously and validating afterwards (#149). * Validation now happens recursively, and validates types before validating the object (#149) * Classes (base types, S3, S4, and S7) are handled consistently wherever they are used. Strings now only refer to base types. New explicit `new_S3_class()` for referring to S3 classes (#134). S4 unions are converted to S7 unions (#150). * Base numeric, atomic, and vector "types" are now represented as class unions (#147). * Different evaluation mechanism for method dispatch, and greater restrictions on dispatch args (#141) * `x@.data` -> `S7_data()`; probably to be replaced by casting. * In generic, `signature` -> `dispatch_args`. * Polished `str()` and `print()` methods * `new_class()` has properties as 3rd argument (instead of constructor). S7/inst/0000755000176200001440000000000014712722347011531 5ustar liggesusersS7/inst/doc/0000755000176200001440000000000014712722347012276 5ustar liggesusersS7/inst/doc/packages.R0000644000176200001440000000056514712722341014177 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(S7) ## ----------------------------------------------------------------------------- .onLoad <- function(...) { S7::methods_register() } S7/inst/doc/performance.R0000644000176200001440000000777714712722346014743 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(S7) ## ----performance, cache = FALSE----------------------------------------------- Text <- new_class("Text", parent = class_character) Number <- new_class("Number", parent = class_double) x <- Text("hi") y <- Number(1) foo_S7 <- new_generic("foo_S7", "x") method(foo_S7, Text) <- function(x, ...) paste0(x, "-foo") foo_S3 <- function(x, ...) { UseMethod("foo_S3") } foo_S3.Text <- function(x, ...) { paste0(x, "-foo") } library(methods) setOldClass(c("Number", "numeric", "S7_object")) setOldClass(c("Text", "character", "S7_object")) setGeneric("foo_S4", function(x, ...) standardGeneric("foo_S4")) setMethod("foo_S4", c("Text"), function(x, ...) paste0(x, "-foo")) # Measure performance of single dispatch bench::mark(foo_S7(x), foo_S3(x), foo_S4(x)) bar_S7 <- new_generic("bar_S7", c("x", "y")) method(bar_S7, list(Text, Number)) <- function(x, y, ...) paste0(x, "-", y, "-bar") setGeneric("bar_S4", function(x, y, ...) standardGeneric("bar_S4")) setMethod("bar_S4", c("Text", "Number"), function(x, y, ...) paste0(x, "-", y, "-bar")) # Measure performance of double dispatch bench::mark(bar_S7(x, y), bar_S4(x, y)) ## ----performance-2, message = FALSE, R.options = list(width = 120), cache = TRUE-------------------------------------- library(S7) gen_character <- function (n, min = 5, max = 25, values = c(letters, LETTERS, 0:9)) { lengths <- sample(min:max, replace = TRUE, size = n) values <- sample(values, sum(lengths), replace = TRUE) starts <- c(1, cumsum(lengths)[-n] + 1) ends <- cumsum(lengths) mapply(function(start, end) paste0(values[start:end], collapse=""), starts, ends) } bench::press( num_classes = c(3, 5, 10, 50, 100), class_nchar = c(15, 100), { # Construct a class hierarchy with that number of classes Text <- new_class("Text", parent = class_character) parent <- Text classes <- gen_character(num_classes, min = class_nchar, max = class_nchar) env <- new.env() for (x in classes) { assign(x, new_class(x, parent = parent), env) parent <- get(x, env) } # Get the last defined class cls <- parent # Construct an object of that class x <- do.call(cls, list("hi")) # Define a generic and a method for the last class (best case scenario) foo_S7 <- new_generic("foo_S7", "x") method(foo_S7, cls) <- function(x, ...) paste0(x, "-foo") # Define a generic and a method for the first class (worst case scenario) foo2_S7 <- new_generic("foo2_S7", "x") method(foo2_S7, S7_object) <- function(x, ...) paste0(x, "-foo") bench::mark( best = foo_S7(x), worst = foo2_S7(x) ) } ) ## ----performance-3, message = FALSE, R.options = list(width = 120), cache = TRUE-------------------------------------- bench::press( num_classes = c(3, 5, 10, 50, 100), class_nchar = c(15, 100), { # Construct a class hierarchy with that number of classes Text <- new_class("Text", parent = class_character) parent <- Text classes <- gen_character(num_classes, min = class_nchar, max = class_nchar) env <- new.env() for (x in classes) { assign(x, new_class(x, parent = parent), env) parent <- get(x, env) } # Get the last defined class cls <- parent # Construct an object of that class x <- do.call(cls, list("hi")) y <- do.call(cls, list("ho")) # Define a generic and a method for the last class (best case scenario) foo_S7 <- new_generic("foo_S7", c("x", "y")) method(foo_S7, list(cls, cls)) <- function(x, y, ...) paste0(x, y, "-foo") # Define a generic and a method for the first class (worst case scenario) foo2_S7 <- new_generic("foo2_S7", c("x", "y")) method(foo2_S7, list(S7_object, S7_object)) <- function(x, y, ...) paste0(x, y, "-foo") bench::mark( best = foo_S7(x, y), worst = foo2_S7(x, y) ) } ) S7/inst/doc/S7.html0000644000176200001440000007262414712722335013465 0ustar liggesusers S7 basics

S7 basics

The S7 package provides a new OOP system designed to be a successor to S3 and S4. It has been designed and implemented collaboratively by the RConsortium Object-Oriented Programming Working Group, which includes representatives from R-Core, BioConductor, RStudio/tidyverse, and the wider R community.

This vignette gives an overview of the most important parts of S7: classes and objects, generics and methods, and the basics of method dispatch and inheritance.

library(S7)

Classes and objects

S7 classes have a formal definition that you create with new_class(). There are two arguments that you’ll use with almost every class:

  • The name of the class, supplied in the first argument.
  • The class properties, the data associated with each instance of the class. The easiest way to define properties is to supply a named list where the values define the valid types of the property.

The following code defines a simple dog class with two properties: a character name and a numeric age.

Dog <- new_class("Dog", properties = list(
  name = class_character,
  age = class_numeric
))
Dog
#> <Dog> class
#> @ parent     : <S7_object>
#> @ constructor: function(name, age) {...}
#> @ validator  : <NULL>
#> @ properties :
#>  $ name: <character>          
#>  $ age : <integer> or <double>

S7 provides a number of built-in definitions that allow you to refer to existing base types that are not S7 classes. You can recognize these definitions because they all start with class_.

Note that I’ve assigned the return value of new_class() to an object with the same name as the class. This is important! That object represents the class and is what you use to construct instances of the class:

lola <- Dog(name = "Lola", age = 11)
lola
#> <Dog>
#>  @ name: chr "Lola"
#>  @ age : num 11

Once you have an S7 object, you can get and set properties using @:

lola@age <- 12
lola@age
#> [1] 12

S7 automatically validates the type of the property using the type supplied in new_class():

lola@age <- "twelve"
#> Error: <Dog>@age must be <integer> or <double>, not <character>

Given an object, you can retrieves its class S7_class():

S7_class(lola)
#> <Dog> class
#> @ parent     : <S7_object>
#> @ constructor: function(name, age) {...}
#> @ validator  : <NULL>
#> @ properties :
#>  $ name: <character>          
#>  $ age : <integer> or <double>

S7 objects also have an S3 class(). This is used for compatibility with existing S3 generics and you can learn more about it in vignette("compatibility").

class(lola)
#> [1] "Dog"       "S7_object"

If you want to learn more about the details of S7 classes and objects, including validation methods and more details of properties, please see vignette("classes-objects").

Generics and methods

S7, like S3 and S4, is built around the idea of generic functions, or generics for short. A generic defines an interface, which uses a different implementation depending on the class of one or more arguments. The implementation for a specific class is called a method, and the generic finds that appropriate method by performing method dispatch.

Use new_generic() to create a S7 generic. In its simplest form, it only needs two arguments: the name of the generic (used in error messages) and the name of the argument used for method dispatch:

speak <- new_generic("speak", "x")

Like with new_class(), you should always assign the result of new_generic() to a variable with the same name as the first argument.

Once you have a generic, you can register methods for specific classes with method(generic, class) <- implementation.

method(speak, Dog) <- function(x) {
  "Woof"
}

Once the method is registered, the generic will use it when appropriate:

speak(lola)
#> [1] "Woof"

Let’s define another class, this one for cats, and define another method for speak():

Cat <- new_class("Cat", properties = list(
  name = class_character,
  age = class_double
))
method(speak, Cat) <- function(x) {
  "Meow"
}

fluffy <- Cat(name = "Fluffy", age = 5)
speak(fluffy)
#> [1] "Meow"

You get an error if you call the generic with a class that doesn’t have a method:

speak(1)
#> Error: Can't find method for `speak(<double>)`.

Method dispatch and inheritance

The cat and dog classes share the same properties, so we could use a common parent class to extract out the duplicated specification. We first define the parent class:

Pet <- new_class("Pet",
  properties = list(
    name = class_character,
    age = class_numeric
  )
)

Then use the parent argument to new_class:

Cat <- new_class("Cat", parent = Pet)
Dog <- new_class("Dog", parent = Pet)

Cat
#> <Cat> class
#> @ parent     : <Pet>
#> @ constructor: function(name, age) {...}
#> @ validator  : <NULL>
#> @ properties :
#>  $ name: <character>          
#>  $ age : <integer> or <double>
Dog
#> <Dog> class
#> @ parent     : <Pet>
#> @ constructor: function(name, age) {...}
#> @ validator  : <NULL>
#> @ properties :
#>  $ name: <character>          
#>  $ age : <integer> or <double>

Because we have created new classes, we need to recreate the existing lola and fluffy objects:

lola <- Dog(name = "Lola", age = 11)
fluffy <- Cat(name = "Fluffy", age = 5)

Method dispatch takes advantage of the hierarchy of parent classes: if a method is not defined for a class, it will try the method for the parent class, and so on until it finds a method or gives up with an error. This inheritance is a powerful mechanism for sharing code across classes.

describe <- new_generic("describe", "x")
method(describe, Pet) <- function(x) {
  paste0(x@name, " is ", x@age, " years old")
}
describe(lola)
#> [1] "Lola is 11 years old"
describe(fluffy)
#> [1] "Fluffy is 5 years old"

method(describe, Dog) <- function(x) {
  paste0(x@name, " is a ", x@age, " year old dog")
}
describe(lola)
#> [1] "Lola is a 11 year old dog"
describe(fluffy)
#> [1] "Fluffy is 5 years old"

You can define a fallback method for any S7 object by registering a method for S7_object:

method(describe, S7_object) <- function(x) {
  "An S7 object"
}

Cocktail <- new_class("Cocktail",
  properties = list(
    ingredients = class_character
  )
)
martini <- Cocktail(ingredients = c("gin", "vermouth"))
describe(martini)
#> [1] "An S7 object"

Printing a generic will show you which methods are currently defined:

describe
#> <S7_generic> describe(x, ...) with 3 methods:
#> 1: method(describe, Dog)
#> 2: method(describe, S7_object)
#> 3: method(describe, Pet)

And you can use method() to retrieve the implementation of one of those methods:

method(describe, Pet)
#> <S7_method> method(describe, Pet)
#> function (x) 
#> {
#>     paste0(x@name, " is ", x@age, " years old")
#> }
#> <bytecode: 0x11631e0b0>

Learn more about method dispatch in vignette("generics-methods").

S7/inst/doc/compatibility.Rmd0000644000176200001440000001034114712423107015602 0ustar liggesusers--- title: "Compatibility with S3 and S4" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Compatibility with S3 and S4} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` S7 is designed to be compatible with S3 and S4. This vignette discusses the details. ```{r setup} library(S7) ``` ## S3 S7 objects *are* S3 objects, because S7 is implemented on top of S3. There are two main differences between an S7 object and an S3 object: - As well as the `class` attribute possessed by S3 objects, S7 objects have an additional `S7_class` attribute that contains the object that defines the class. - S7 objects have properties; S3 objects have attributes. Properties are implemented on top of attributes, so you can access them directly with `attr` and friends. When working inside of S7, you should never use attributes directly, but it does mean that existing code will continue to work. All up, this means most usage of S7 with S3 will just work. - S7 can register methods for: - S7 class and S3 generic - S3 class and S7 generic - S7 classes can extend S3 classes - S3 classes can extend S7 classes ### Methods `method()` is designed to be the single tool for method registration that you need when working with S7 classes. You can also register a method for an S7 class and S3 generic without using S7, because all S7 objects have S3 classes, and S3 dispatch will operate on them normally. ```{r} Foo <- new_class("Foo") class(Foo()) mean.Foo <- function(x, ...) { "mean of foo" } mean(Foo()) ``` ### Classes It's possible to extend an S7 class with S3. This is primarily useful because in many cases it allows you to change a class hierarchy from the inside out: you can provide a formal definition of an S3 class using S7, and its subclasses don't need to change. ### List classes Many simple S3 classes are implemented as lists, e.g. rle. ```{r} rle <- function(x) { if (!is.vector(x) && !is.list(x)) { stop("'x' must be a vector of an atomic type") } n <- length(x) if (n == 0L) { new_rle(integer(), x) } else { y <- x[-1L] != x[-n] i <- c(which(y | is.na(y)), n) new_rle(diff(c(0L, i)), x[i]) } } new_rle <- function(lengths, values) { structure( list( lengths = lengths, values = values ), class = "rle" ) } ``` There are two ways to convert this to S7. You could keep the structure exactly the same, using a `list` as the underlying data structure and using a constructor to enforce the structure: ```{r} new_rle <- new_class("rle", parent = class_list, constructor = function(lengths, values) { new_object(list(lengths = lengths, values = values)) } ) rle(1:10) ``` Alternatively you could convert it to the most natural representation using S7: ```{r} rle <- new_class("rle", properties = list( lengths = class_integer, values = class_atomic )) ``` To allow existing methods to work you'll need to override `$` to access properties instead of list elements: ```{r} method(`$`, rle) <- prop rle(1:10) ``` The chief disadvantage of this approach is any subclasses will need to be converted to S7 as well. ## S4 S7 properties are equivalent to S4 slots. The chief difference is that they can be dynamic. - S7 classes can not extend S4 classes - S4 classes can extend S3 classes - S7 can register methods for: - S7 class and S4 generic - S4 class and S7 generic ### Unions S4 unions are automatically converted to S7 unions. There's an important difference in the way that class unions are handled in S4 and S7. In S4, they're handled at method dispatch time, so when you create `setUnion("u1", c("class1", "class2"))`, `class1` and `class2` now extend `u1`. In S7, unions are handled at method registration time so that registering a method for a union is just short-hand for registering a method for each of the classes. ```{r} Class1 <- new_class("Class1") Class2 <- new_class("Class2") Union1 <- new_union(Class1, Class2) foo <- new_generic("foo", "x") method(foo, Union1) <- function(x) "" foo ``` S7 unions allow you to restrict the type of a property in the same way that S4 unions allow you to restrict the type of a slot. S7/inst/doc/generics-methods.Rmd0000644000176200001440000002503414712423107016176 0ustar liggesusers--- title: "Generics and methods" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Generics and methods} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` This vignette dives into the details of S7 generics and method dispatch, building on the basics discussed in `vignette("S7")`. We'll first introduce the concept of generic-method compatibility, then discuss some of the finer details of creating a generic with `new_generic()`. This vignette first discusses generic-method compatibility, and you might want to customize the body of the generic, and generics that live in suggested packages. We'll then pivot to talk more details of method dispatch including `super()` and multiple dispatch. ```{r setup} library(S7) ``` ## Generic-method compatibility When you register a method, S7 checks that your method is compatible with the generic. The formal arguments of the generic and methods must agree. This means that: - Any arguments that the generic has, the method must have too. In particular, the arguments of the method start with the arguments that the generic dispatches on, and those arguments must not have default arguments. - The method can contain arguments that the generic does not, as long as the generic includes `…` in the argument list. ### Generic with dots; method without dots The default generic includes `…` but generally the methods should not. That ensures that misspelled arguments won't be silently swallowed by the method. This is an important difference from S3. Take a very simple implementation of `mean()`: ```{r} mean <- new_generic("mean", "x") method(mean, class_numeric) <- function(x) sum(x) / length(x) ``` If we pass an additional argument in, we'll get an error: ```{r, error = TRUE, eval = FALSE} mean(100, na.rm = TRUE) ``` But we can still add additional arguments if we desired: ```{r} method(mean, class_numeric) <- function(x, na.rm = TRUE) { if (na.rm) { x <- x[!is.na(x)] } sum(x) / length(x) } mean(c(100, NA), na.rm = TRUE) ``` (We'll come back to the case of requiring that all methods implement a `na.rm = TRUE` argument shortly.) ### Generic and method with dots There are cases where you do need to take `…` in a method, which is particularly problematic if you need to re-call the generic recursively. For example, imagine a simple print method like this: ```{r} simple_print <- new_generic("simple_print", "x") method(simple_print, class_double) <- function(x, digits = 3) {} method(simple_print, class_character) <- function(x, max_length = 100) {} ``` What if you want to print a list? ```{r} method(simple_print, class_list) <- function(x, ...) { for (el in x) { simple_print(el, ...) } } ``` It's fine as long as all the elements of the list are numbers, but as soon as we add a character vector, we get an error: ```{r, error = TRUE, eval = FALSE} simple_print(list(1, 2, 3), digits = 3) simple_print(list(1, 2, "x"), digits = 3) ``` To solve this situation, methods generally need to ignore arguments that they haven't been specifically designed to handle, i.e. they need to use `…`: ```{r} method(simple_print, class_double) <- function(x, ..., digits = 3) {} method(simple_print, class_character) <- function(x, ..., max_length = 100) {} simple_print(list(1, 2, "x"), digits = 3) ``` In this case we really do want to silently ignore unknown arguments because they might apply to other methods. There's unfortunately no easy way to avoid this problem without relying on fairly esoteric technology (as done by `rlang::check_dots_used()`). ```{r} simple_print(list(1, 2, "x"), diggits = 3) ``` ### Generic and method without dots Occasional it's useful to create a generic without `…` because such functions have a useful property: if a call succeeds for one type of input, it will succeed for any type of input. To create such a generic, you'll need to use the third argument to `new_generic()`: an optional function that powers the generic. This function has one key property: it must call `call_method()` to actually perform dispatch. In general, this property is only needed for very low-level functions with precisely defined semantics. A good example of such a function is `length()`: ```{r, eval = FALSE} length <- new_generic("length", "x", function(x) { S7_dispatch() }) ``` Omitting `…` from the generic signature is a strong restriction as it prevents methods from adding extra arguments. For this reason, it's should only be used in special situations. ## Customizing generics In most cases, you'll supply the first two arguments to `new_generic()` and allow it to automatically generate the body of the generic: ```{r} display <- new_generic("display", "x") S7_data(display) ``` The most important part of the body is `S7_dispatch()`; this function finds the method the matches the arguments used for dispatch and calls it with the arguments supplied to the generic. It can be useful to customize this body. The previous section showed one case when you might want to supply the body yourself: dropping `…` from the formals of the generic. There are three other useful cases: - To add required arguments. - To add optional arguments. - Perform some standard work. A custom `fun` must always include a call to `call_method()`, which will usually be the last call. ### Add required arguments To add required arguments that aren't dispatched upon, you just need to add additional arguments that lack default values: ```{r} foo <- new_generic("foo", "x", function(x, y, ...) { S7_dispatch() }) ``` Now all methods will need to provide that `y` argument. If not, you'll get a warning: ```{r} method(foo, class_integer) <- function(x, ...) { 10 } ``` This is a warning, not an error, because the generic might be defined in a different package and is in the process of changing interfaces. You'll always want to address this warning when you see it. ### Add optional arguments Adding an optional argument is similar, but it should generally come after `…`. This ensures that the user must supply the full name of the argument when calling the function, which makes it easier to extend your function in the future. ```{r} mean <- new_generic("mean", "x", function(x, ..., na.rm = TRUE) { S7_dispatch() }) method(mean, class_integer) <- function(x, na.rm = TRUE) { if (na.rm) { x <- x[!is.na(x)] } sum(x) / length(x) } ``` Forgetting the argument or using a different default value will again generate a warning. ```{r} method(mean, class_double) <- function(x, na.rm = FALSE) {} method(mean, class_logical) <- function(x) {} ``` ### Do some work If your generic has additional arguments, you might want to do some additional work to verify that they're of the expected type. For example, our `mean()` function could verify that `na.rm` was correctly specified: ```{r} mean <- new_generic("mean", "x", function(x, ..., na.rm = TRUE) { if (!identical(na.rm, TRUE) && !identical(na.rm = FALSE)) { stop("`na.rm` must be either TRUE or FALSE") } S7_dispatch() }) ``` The only downside to performing error checking is that you constraint the interface for all methods; if for some reason a method found it useful to allow `na.rm` to be a number or a string, it would have to provide an alternative argument. ## `super()` Sometimes it's useful to define a method for in terms of its superclass. A good example of this is computing the mean of a date --- since dates represent the number of days since 1970-01-01, computing the mean is just a matter of computing the mean of the underlying numeric vector and converting it back to a date. To demonstrate this idea, I'll first define a mean generic with a method for numbers: ```{r} mean <- new_generic("mean", "x") method(mean, class_numeric) <- function(x) { sum(x) / length(x) } mean(1:10) ``` And a Date class: ```{r} date <- new_class("date", parent = class_double) # Cheat by using the existing base .Date class method(print, date) <- function(x) print(.Date(x)) date(c(1, 10, 100)) ``` Now to compute a mean we write: ```{r} method(mean, date) <- function(x) { date(mean(super(x, to = class_double))) } mean(date(c(1, 10, 100))) ``` Let's unpack this method from the inside out: 1. First we call `super(x, to = class_double)` --- this will make the call to next generic treat `x` like it's a double, rather than a date. 2. Then we call `mean()` which because of `super()` will call the `mean()` method we defined above. 3. Finally, we take the number returned by mean and convert it back to a date. If you're very familiar with S3 or S4 you might recognize that `super()` fills a similar role to `NextMethod()` or `callNextMethod()`. However, it's much more explicit: you need to supply the name of the parent class, the generic to use, and all the arguments to the generic. This explicitness makes the code easier to understand and will eventually enable certain performance optimizations that would otherwise be very difficult. ## Multiple dispatch So far we have focused primarily on single dispatch, i.e. generics where `dispatch_on` is a single string. It is also possible to supply a length 2 (or more!) vector `dispatch_on` to create a generic that performs multiple dispatch, i.e. it uses the classes of more than one object to find the appropriate method. Multiple dispatch is a feature primarily of S4, although S3 includes some limited special cases for arithmetic operators. Multiple dispatch is heavily used in S4; we don't expect it to be heavily used in S7, but it is occasionally useful. ### A simple example Let's take our speak example from `vignette("S7")` and extend it to teach our pets how to speak multiple languages: ```{r} Pet <- new_class("Pet") Dog <- new_class("Dog", Pet) Cat <- new_class("Cat", Pet) Language <- new_class("Language") English <- new_class("English", Language) French <- new_class("French", Language) speak <- new_generic("speak", c("x", "y")) method(speak, list(Dog, English)) <- function(x, y) "Woof" method(speak, list(Cat, English)) <- function(x, y) "Meow" method(speak, list(Dog, French)) <- function(x, y) "Ouaf Ouaf" method(speak, list(Cat, French)) <- function(x, y) "Miaou" speak(Cat(), English()) speak(Dog(), French()) # This example was originally inspired by blog.klipse.tech/javascript/2021/10/03/multimethod.html # which has unfortunately since disappeared. ``` ### Special "classes" There are two special classes that become particularly useful with multiple dispatch: - `class_any()` will match any class - `class_missing()` will match a missing argument (i.e. not `NA`, but an argument that was not supplied) S7/inst/doc/S7.R0000644000176200001440000000573614712722334012721 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(S7) ## ----------------------------------------------------------------------------- Dog <- new_class("Dog", properties = list( name = class_character, age = class_numeric )) Dog ## ----------------------------------------------------------------------------- lola <- Dog(name = "Lola", age = 11) lola ## ----------------------------------------------------------------------------- lola@age <- 12 lola@age ## ----error = TRUE------------------------------------------------------------- lola@age <- "twelve" ## ----------------------------------------------------------------------------- S7_class(lola) ## ----------------------------------------------------------------------------- class(lola) ## ----------------------------------------------------------------------------- speak <- new_generic("speak", "x") ## ----------------------------------------------------------------------------- method(speak, Dog) <- function(x) { "Woof" } ## ----------------------------------------------------------------------------- speak(lola) ## ----------------------------------------------------------------------------- Cat <- new_class("Cat", properties = list( name = class_character, age = class_double )) method(speak, Cat) <- function(x) { "Meow" } fluffy <- Cat(name = "Fluffy", age = 5) speak(fluffy) ## ----error = TRUE------------------------------------------------------------- speak(1) ## ----------------------------------------------------------------------------- Pet <- new_class("Pet", properties = list( name = class_character, age = class_numeric ) ) ## ----------------------------------------------------------------------------- Cat <- new_class("Cat", parent = Pet) Dog <- new_class("Dog", parent = Pet) Cat Dog ## ----------------------------------------------------------------------------- lola <- Dog(name = "Lola", age = 11) fluffy <- Cat(name = "Fluffy", age = 5) ## ----------------------------------------------------------------------------- describe <- new_generic("describe", "x") method(describe, Pet) <- function(x) { paste0(x@name, " is ", x@age, " years old") } describe(lola) describe(fluffy) method(describe, Dog) <- function(x) { paste0(x@name, " is a ", x@age, " year old dog") } describe(lola) describe(fluffy) ## ----------------------------------------------------------------------------- method(describe, S7_object) <- function(x) { "An S7 object" } Cocktail <- new_class("Cocktail", properties = list( ingredients = class_character ) ) martini <- Cocktail(ingredients = c("gin", "vermouth")) describe(martini) ## ----------------------------------------------------------------------------- describe ## ----------------------------------------------------------------------------- method(describe, Pet) S7/inst/doc/compatibility.html0000644000176200001440000005025114712722337016037 0ustar liggesusers Compatibility with S3 and S4

Compatibility with S3 and S4

S7 is designed to be compatible with S3 and S4. This vignette discusses the details.

library(S7)

S3

S7 objects are S3 objects, because S7 is implemented on top of S3. There are two main differences between an S7 object and an S3 object:

  • As well as the class attribute possessed by S3 objects, S7 objects have an additional S7_class attribute that contains the object that defines the class.

  • S7 objects have properties; S3 objects have attributes. Properties are implemented on top of attributes, so you can access them directly with attr and friends. When working inside of S7, you should never use attributes directly, but it does mean that existing code will continue to work.

All up, this means most usage of S7 with S3 will just work.

  • S7 can register methods for:

    • S7 class and S3 generic
    • S3 class and S7 generic

  • S7 classes can extend S3 classes

  • S3 classes can extend S7 classes

Methods

method() is designed to be the single tool for method registration that you need when working with S7 classes. You can also register a method for an S7 class and S3 generic without using S7, because all S7 objects have S3 classes, and S3 dispatch will operate on them normally.

Foo <- new_class("Foo")
class(Foo())
#> [1] "Foo"       "S7_object"

mean.Foo <- function(x, ...) {
  "mean of foo"
}

mean(Foo())
#> [1] "mean of foo"

Classes

It’s possible to extend an S7 class with S3. This is primarily useful because in many cases it allows you to change a class hierarchy from the inside out: you can provide a formal definition of an S3 class using S7, and its subclasses don’t need to change.

List classes

Many simple S3 classes are implemented as lists, e.g. rle.

rle <- function(x) {
  if (!is.vector(x) && !is.list(x)) {
    stop("'x' must be a vector of an atomic type")
  }
  n <- length(x)
  if (n == 0L) {
    new_rle(integer(), x)
  } else {
    y <- x[-1L] != x[-n]
    i <- c(which(y | is.na(y)), n)
    new_rle(diff(c(0L, i)), x[i])
  }
}
new_rle <- function(lengths, values) {
  structure(
    list(
      lengths = lengths,
      values = values
    ),
    class = "rle"
  )
}

There are two ways to convert this to S7. You could keep the structure exactly the same, using a list as the underlying data structure and using a constructor to enforce the structure:

new_rle <- new_class("rle",
  parent = class_list,
  constructor = function(lengths, values) {
    new_object(list(lengths = lengths, values = values))
  }
)
rle(1:10)
#> Run Length Encoding
#>   lengths: int [1:10] 1 1 1 1 1 1 1 1 1 1
#>   values : int [1:10] 1 2 3 4 5 6 7 8 9 10

Alternatively you could convert it to the most natural representation using S7:

rle <- new_class("rle", properties = list(
  lengths = class_integer,
  values = class_atomic
))

To allow existing methods to work you’ll need to override $ to access properties instead of list elements:

method(`$`, rle) <- prop
rle(1:10)
#> Run Length Encoding
#>   lengths: int [1:10] 1 2 3 4 5 6 7 8 9 10
#>   values : logi(0)

The chief disadvantage of this approach is any subclasses will need to be converted to S7 as well.

S4

S7 properties are equivalent to S4 slots. The chief difference is that they can be dynamic.

  • S7 classes can not extend S4 classes
  • S4 classes can extend S3 classes
  • S7 can register methods for:
    • S7 class and S4 generic
    • S4 class and S7 generic

Unions

S4 unions are automatically converted to S7 unions. There’s an important difference in the way that class unions are handled in S4 and S7. In S4, they’re handled at method dispatch time, so when you create setUnion("u1", c("class1", "class2")), class1 and class2 now extend u1. In S7, unions are handled at method registration time so that registering a method for a union is just short-hand for registering a method for each of the classes.

Class1 <- new_class("Class1")
Class2 <- new_class("Class2")
Union1 <- new_union(Class1, Class2)

foo <- new_generic("foo", "x")
method(foo, Union1) <- function(x) ""
foo
#> <S7_generic> foo(x, ...) with 2 methods:
#> 1: method(foo, Class2)
#> 2: method(foo, Class1)

S7 unions allow you to restrict the type of a property in the same way that S4 unions allow you to restrict the type of a slot.

S7/inst/doc/packages.Rmd0000644000176200001440000000617514533115246014524 0ustar liggesusers--- title: "Using S7 in a package" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Using S7 in a package} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` This vignette outlines the most important things you need to know about using S7 in a package. S7 is new, so few people have used it in a package yet; this means that this vignette is likely incomplete, and we'd love your help to make it better. Please [let us know](https://github.com/RConsortium/S7/issues/new) if you have questions that this vignette doesn't answer. ```{r setup} library(S7) ``` ## Method registration You should always call `methods_register()` in your `.onLoad()`: ```{r} .onLoad <- function(...) { S7::methods_register() } ``` This is S7's way of registering methods, rather than using export directives in your `NAMESPACE` like S3 and S4 do. This is only strictly necessary if registering methods for generics in other packages, but there's no harm in adding it and it ensures that you won't forget later. (And if you're not importing S7 into your namespace it will quiet an `R CMD check` `NOTE`.`)` ## Documentation and exports If you want users to create instances of your class, you will need to export the class constructor. That means you will also need to document it, and since the constructor is a function, that means you have to document the arguments which will be the properties of the class (unless you have customised the constructor). If you export a class, you must also set the `package` argument, ensuring that classes with the same name are disambiguated across packages. You should document generics like regular functions (since they are!). If you expect others to create their own methods for your generic, you may want to include an section describing the the properties that you expect all methods to have. We plan to provide a an easy way to all methods for a generic, but have not yet implemented it. You can track progress at . We don't currently have any recommendations on documenting methods. There's no need to document them in order to pass `R CMD check`, but obviously there are cases where it's nice to provide additional details for a method, particularly if it takes extra arguments compared to the generic. We're tracking that issue at . ## Backward compatibility If you are using S7 in a package *and* you want your package to work in versions of R before 4.3.0, you need to know that in these versions of R `@` only works with S4 objects. There are two workarounds. The easiest and least convenient workaround is to just `prop()` instead of `@`. Otherwise, you can conditionally make an S7-aware `@` available to your package with this custom `NAMESPACE` directive: ``` r # enable usage of @name in package code #' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@") NULL ``` `@` will work for users of your package because S7 automatically attaches an environment containing the needed definition when it's loaded. S7/inst/doc/classes-objects.R0000644000176200001440000001466714712722336015521 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(S7) ## ----------------------------------------------------------------------------- Range <- new_class("Range", properties = list( start = class_double, end = class_double ), validator = function(self) { if (length(self@start) != 1) { "@start must be length 1" } else if (length(self@end) != 1) { "@end must be length 1" } else if (self@end < self@start) { sprintf( "@end (%i) must be greater than or equal to @start (%i)", self@end, self@start ) } } ) ## ----error = TRUE------------------------------------------------------------- x <- Range(1, 2:3) x <- Range(10, 1) x <- Range(1, 10) x@start <- 20 ## ----error = TRUE------------------------------------------------------------- x <- Range(1, 2) attr(x, "start") <- 3 validate(x) ## ----------------------------------------------------------------------------- shift <- function(x, shift) { x@start <- x@start + shift x@end <- x@end + shift x } shift(Range(1, 10), 1) ## ----error = TRUE------------------------------------------------------------- shift(Range(1, 10), 10) ## ----------------------------------------------------------------------------- shift <- function(x, shift) { props(x) <- list( start = x@start + shift, end = x@end + shift ) x } shift(Range(1, 10), 10) ## ----------------------------------------------------------------------------- Range <- new_class("Range", properties = list( start = new_property(class_double), end = new_property(class_double) ) ) ## ----error = TRUE------------------------------------------------------------- prop_number <- new_property( class = class_double, validator = function(value) { if (length(value) != 1L) "must be length 1" } ) Range <- new_class("Range", properties = list( start = prop_number, end = prop_number ), validator = function(self) { if (self@end < self@start) { sprintf( "@end (%i) must be greater than or equal to @start (%i)", self@end, self@start ) } } ) Range(start = c(1.5, 3.5)) Range(end = c(1.5, 3.5)) ## ----------------------------------------------------------------------------- Empty <- new_class("Empty", properties = list( x = class_double, y = class_character, z = class_logical )) Empty() ## ----------------------------------------------------------------------------- Empty <- new_class("Empty", properties = list( x = new_property(class_numeric, default = 0), y = new_property(class_character, default = ""), z = new_property(class_logical, default = NA) ) ) Empty() ## ----------------------------------------------------------------------------- Stopwatch <- new_class("Stopwatch", properties = list( start_time = new_property( class = class_POSIXct, default = quote(Sys.time()) ), elapsed = new_property( getter = function(self) { difftime(Sys.time(), self@start_time, units = "secs") } ) )) args(Stopwatch) round(Stopwatch()@elapsed) round(Stopwatch(Sys.time() - 1)@elapsed) ## ----------------------------------------------------------------------------- Range <- new_class("Range", properties = list( start = class_double, end = class_double, length = new_property( getter = function(self) self@end - self@start, ) ) ) x <- Range(start = 1, end = 10) x ## ----error = TRUE------------------------------------------------------------- x@length <- 20 ## ----------------------------------------------------------------------------- Range <- new_class("Range", properties = list( start = class_double, end = class_double, length = new_property( class = class_double, getter = function(self) self@end - self@start, setter = function(self, value) { self@end <- self@start + value self } ) ) ) x <- Range(start = 1, end = 10) x x@length <- 5 x ## ----------------------------------------------------------------------------- Person <- new_class("Person", properties = list( first_name = class_character, firstName = new_property( class_character, default = quote(first_name), getter = function(self) { warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) self@first_name }, setter = function(self, value) { if (identical(value, self@first_name)) { return(self) } warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) self@first_name <- value self } ) )) args(Person) hadley <- Person(firstName = "Hadley") hadley <- Person(first_name = "Hadley") # no warning hadley@firstName hadley@firstName <- "John" hadley@first_name # no warning ## ----------------------------------------------------------------------------- Person <- new_class("Person", properties = list( name = new_property( class_character, validator = function(value) { if (length(value) != 1 || is.na(value) || value == "") "must be a non-empty string" } ) )) try(Person()) try(Person(1)) # class_character$validator() is also checked. Person("Alice") ## ----------------------------------------------------------------------------- Person <- new_class("Person", properties = list( name = new_property( class_character, default = quote(stop("@name is required"))) )) try(Person()) Person("Alice") ## ----------------------------------------------------------------------------- Person <- new_class("Person", properties = list( birth_date = new_property( class_Date, setter = function(self, value) { if(!is.null(self@birth_date)) { stop("@birth_date is read-only", call. = FALSE) } self@birth_date <- as.Date(value) self } ))) person <- Person("1999-12-31") try(person@birth_date <- "2000-01-01") ## ----------------------------------------------------------------------------- Range@constructor ## ----------------------------------------------------------------------------- Range <- new_class("Range", properties = list( start = class_numeric, end = class_numeric ), constructor = function(x) { new_object(S7_object(), start = min(x, na.rm = TRUE), end = max(x, na.rm = TRUE)) } ) range(c(10, 5, 0, 2, 5, 7)) S7/inst/doc/motivation.Rmd0000644000176200001440000001131314533115246015125 0ustar liggesusers--- title: "Motivation for S7" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Motivation for S7} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` R already has two OO systems built-in (S3 and S4) and many additional OO systems are available in CRAN packages. Why did we decide more work was needed? This vignette will discuss some of the motivations behind S7, focussing on the aspects of S3 and S4 that have been found to be particularly challenging in practice. ```{r setup} library(S7) ``` ## Challenges with S3 - S3 is very informal, meaning that there's no formal definition of a class. This makes it impossible to know exactly which properties an object should or could possess, or even what its parent class should be. S7 resolves this problem with a formal definition encoded in a class object produced by `new_class()`. This includes support for validation (and avoiding validation where needed) as inspired by S4. - When a new user encounter an S3 generic, they are often confused because the implementation of the function appears to be missing. S7 has a thoughtfully designed print method that makes it clear what methods are available and how to find their source code. - Properties of an S3 class are usually stored in attributes, but, by default, `attr()` does partial matching, which can lead to bugs that are hard to diagnose. Additionally, `attr()` returns `NULL` if an attribute doesn't exist, so misspelling an attribute can lead to subtle bugs. `@` fixes both of these problems. - S3 method dispatch is complicated for compatibility with S. This complexity affects relatively little code, but when you attempt to dive into the details it makes `UseMethod()` hard to understand. As much as possible, S7 avoids any "funny" business with environments or promises, so that there is no distinction between argument values and local values. - S3 is primarily designed for single dispatch and double dispatch is only provided for a handful of base generics. It's not possible to reuse the implementation for user generics. S7 provides a standard way of doing multiple dispatch (including double dispatch) that can be used for any generic. - `NextMethod()` is unpredictable since you can't tell exactly which method will be called by only reading the code; you instead need to know both the complete class hierarchy and what other methods are currently registered (and loading a package might change those methods). S7 takes a difference approach with `super()`, requiring explicit specification of the superclass to be used. - Conversion between S3 classes is only implemented via loose convention: if you implement a class `foo`, then you should also provide generic `as.foo()` to convert other objects to that type. S7 avoids this problem by providing the double-dispatch `convert()` generic so that you only need to provide the appropriate methods. ## Challenges with S4 - Multiple inheritance seemed like a powerful idea at the time, but in practice it appears to generate more problems than it solves. S7 does not support multiple inheritance. - S4's method dispatch uses a principled but complex distance metric to pick the best method in the presence of ambiguity. Time has shown that this approach is hard for people to understand and makes it hard to predict what will happen when new methods are registered. S7 implements a much simpler, greedy, approach that trades some additional work on behalf of the class author for a system that is simpler and easier to understand. - S4 is a clean break from S3. This made it possible to make radical changes but it made it harder to switch from S3 to S4, leading to a general lack of adoption in the R community. S7 is designed to be drop-in compatible with S3, making it possible to convert existing packages to use S7 instead of S3 with only an hour or two of work. - At least within Bioconductor, slots are generally thought of as implementation detail that should not be directly accessed by the end-user. This leads to two problems. Firstly, implementing an S4 Bioconductor class often also requires a plethora of accessor functions that are a thin wrapper around `@` or `@<-`. Secondly, users know about `@` and use it to access object internals even though they're not supposed to. S7 avoids these problems by accepting the fact that R is a data language, and that there's no way to stop users from pulling the data they need out of an object. To make it possible to change the internal implementation details of an object while preserving existing `@` usage, S7 provides dynamic properties. S7/inst/doc/performance.html0000644000176200001440000011060014712722347015463 0ustar liggesusers Performance

Performance

library(S7)

The dispatch performance should be roughly on par with S3 and S4, though as this is implemented in a package there is some overhead due to .Call vs .Primitive.

Text <- new_class("Text", parent = class_character)
Number <- new_class("Number", parent = class_double)

x <- Text("hi")
y <- Number(1)

foo_S7 <- new_generic("foo_S7", "x")
method(foo_S7, Text) <- function(x, ...) paste0(x, "-foo")

foo_S3 <- function(x, ...) {
  UseMethod("foo_S3")
}

foo_S3.Text <- function(x, ...) {
  paste0(x, "-foo")
}

library(methods)
setOldClass(c("Number", "numeric", "S7_object"))
setOldClass(c("Text", "character", "S7_object"))

setGeneric("foo_S4", function(x, ...) standardGeneric("foo_S4"))
#> [1] "foo_S4"
setMethod("foo_S4", c("Text"), function(x, ...) paste0(x, "-foo"))

# Measure performance of single dispatch
bench::mark(foo_S7(x), foo_S3(x), foo_S4(x))
#> # A tibble: 3 × 6
#>   expression      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 foo_S7(x)    3.69µs   4.14µs   233552.        0B     70.1
#> 2 foo_S3(x)    1.35µs   1.48µs   616660.        0B      0  
#> 3 foo_S4(x)    1.48µs   1.64µs   586204.        0B     58.6

bar_S7 <- new_generic("bar_S7", c("x", "y"))
method(bar_S7, list(Text, Number)) <- function(x, y, ...) paste0(x, "-", y, "-bar")

setGeneric("bar_S4", function(x, y, ...) standardGeneric("bar_S4"))
#> [1] "bar_S4"
setMethod("bar_S4", c("Text", "Number"), function(x, y, ...) paste0(x, "-", y, "-bar"))

# Measure performance of double dispatch
bench::mark(bar_S7(x, y), bar_S4(x, y))
#> # A tibble: 2 × 6
#>   expression        min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>   <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 bar_S7(x, y)   6.89µs   7.63µs   125512.        0B     50.2
#> 2 bar_S4(x, y)   3.94µs    4.3µs   223593.        0B     44.7

A potential optimization is caching based on the class names, but lookup should be fast without this.

The following benchmark generates a class hierarchy of different levels and lengths of class names and compares the time to dispatch on the first class in the hierarchy vs the time to dispatch on the last class.

We find that even in very extreme cases (e.g. 100 deep hierarchy 100 of character class names) the overhead is reasonable, and for more reasonable cases (e.g. 10 deep hierarchy of 15 character class names) the overhead is basically negligible.

library(S7)

gen_character <- function (n, min = 5, max = 25, values = c(letters, LETTERS, 0:9)) {
  lengths <- sample(min:max, replace = TRUE, size = n)
  values <- sample(values, sum(lengths), replace = TRUE)
  starts <- c(1, cumsum(lengths)[-n] + 1)
  ends <- cumsum(lengths)
  mapply(function(start, end) paste0(values[start:end], collapse=""), starts, ends)
}

bench::press(
  num_classes = c(3, 5, 10, 50, 100),
  class_nchar = c(15, 100),
  {
    # Construct a class hierarchy with that number of classes
    Text <- new_class("Text", parent = class_character)
    parent <- Text
    classes <- gen_character(num_classes, min = class_nchar, max = class_nchar)
    env <- new.env()
    for (x in classes) {
      assign(x, new_class(x, parent = parent), env)
      parent <- get(x, env)
    }

    # Get the last defined class
    cls <- parent

    # Construct an object of that class
    x <- do.call(cls, list("hi"))

    # Define a generic and a method for the last class (best case scenario)
    foo_S7 <- new_generic("foo_S7", "x")
    method(foo_S7, cls) <- function(x, ...) paste0(x, "-foo")

    # Define a generic and a method for the first class (worst case scenario)
    foo2_S7 <- new_generic("foo2_S7", "x")
    method(foo2_S7, S7_object) <- function(x, ...) paste0(x, "-foo")

    bench::mark(
      best = foo_S7(x),
      worst = foo2_S7(x)
    )
  }
)
#> # A tibble: 20 × 8
#>    expression num_classes class_nchar      min   median `itr/sec` mem_alloc `gc/sec`
#>    <bch:expr>       <dbl>       <dbl> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#>  1 best                 3          15   3.73µs   4.14µs   233715.        0B     46.8
#>  2 worst                3          15   3.85µs   4.26µs   226893.        0B     68.1
#>  3 best                 5          15   3.73µs    4.1µs   235608.        0B     70.7
#>  4 worst                5          15    3.9µs    4.3µs   226792.        0B     68.1
#>  5 best                10          15   3.73µs   4.14µs   234855.        0B     70.5
#>  6 worst               10          15   4.06µs   4.51µs   215358.        0B     64.6
#>  7 best                50          15    4.1µs   4.51µs   215821.        0B     64.8
#>  8 worst               50          15   5.49µs   5.99µs   163775.        0B     49.1
#>  9 best               100          15   4.51µs   5.12µs   189758.        0B     56.9
#> 10 worst              100          15   7.42µs      8µs   123380.        0B     37.0
#> 11 best                 3         100   3.77µs   4.18µs   233487.        0B     93.4
#> 12 worst                3         100   3.98µs   4.55µs   212867.        0B     63.9
#> 13 best                 5         100    3.9µs   4.55µs   207037.        0B     41.4
#> 14 worst                5         100   4.43µs   4.96µs   192327.        0B     57.7
#> 15 best                10         100   3.73µs   4.22µs   223713.        0B     67.1
#> 16 worst               10         100   4.84µs   5.33µs   181142.        0B     54.4
#> 17 best                50         100   4.18µs   4.63µs   207896.        0B     41.6
#> 18 worst               50         100  10.21µs  10.87µs    89545.        0B     26.9
#> 19 best               100         100   4.47µs   5.04µs   186869.        0B     37.4
#> 20 worst              100         100  15.46µs  16.32µs    59365.        0B     17.8

And the same benchmark using double-dispatch

bench::press(
  num_classes = c(3, 5, 10, 50, 100),
  class_nchar = c(15, 100),
  {
    # Construct a class hierarchy with that number of classes
    Text <- new_class("Text", parent = class_character)
    parent <- Text
    classes <- gen_character(num_classes, min = class_nchar, max = class_nchar)
    env <- new.env()
    for (x in classes) {
      assign(x, new_class(x, parent = parent), env)
      parent <- get(x, env)
    }

    # Get the last defined class
    cls <- parent

    # Construct an object of that class
    x <- do.call(cls, list("hi"))
    y <- do.call(cls, list("ho"))

    # Define a generic and a method for the last class (best case scenario)
    foo_S7 <- new_generic("foo_S7", c("x", "y"))
    method(foo_S7, list(cls, cls)) <- function(x, y, ...) paste0(x, y, "-foo")

    # Define a generic and a method for the first class (worst case scenario)
    foo2_S7 <- new_generic("foo2_S7", c("x", "y"))
    method(foo2_S7, list(S7_object, S7_object)) <- function(x, y, ...) paste0(x, y, "-foo")

    bench::mark(
      best = foo_S7(x, y),
      worst = foo2_S7(x, y)
    )
  }
)
#> # A tibble: 20 × 8
#>    expression num_classes class_nchar      min   median `itr/sec` mem_alloc `gc/sec`
#>    <bch:expr>       <dbl>       <dbl> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#>  1 best                 3          15   4.63µs   5.25µs   178156.        0B    71.3 
#>  2 worst                3          15   4.84µs   5.62µs   162908.        0B    48.9 
#>  3 best                 5          15   4.67µs   5.25µs   178662.        0B    71.5 
#>  4 worst                5          15   5.04µs   5.66µs   168251.        0B    50.5 
#>  5 best                10          15   4.67µs   5.04µs   190060.        0B    76.1 
#>  6 worst               10          15   5.25µs   5.66µs   171466.        0B    51.5 
#>  7 best                50          15   5.29µs    5.7µs   167396.        0B    67.0 
#>  8 worst               50          15   7.71µs   8.32µs   114879.        0B    34.5 
#>  9 best               100          15   6.07µs   6.68µs   141150.        0B    56.5 
#> 10 worst              100          15  11.52µs   12.3µs    78719.        0B    23.6 
#> 11 best                 3         100   4.59µs   5.08µs   187697.        0B    75.1 
#> 12 worst                3         100   5.41µs   6.03µs   154788.        0B    46.5 
#> 13 best                 5         100   4.88µs   5.37µs   178631.        0B    71.5 
#> 14 worst                5         100   5.54µs   6.03µs   160767.        0B    48.2 
#> 15 best                10         100      5µs   5.66µs   160065.        0B    64.1 
#> 16 worst               10         100   7.58µs   8.04µs   118897.        0B    35.7 
#> 17 best                50         100   5.25µs    5.7µs   169331.        0B    50.8 
#> 18 worst               50         100  15.29µs  16.15µs    59015.        0B    23.6 
#> 19 best               100         100   5.95µs   6.44µs   149406.        0B    44.8 
#> 20 worst              100         100  28.99µs  29.97µs    32367.        0B     9.71
S7/inst/doc/S7.Rmd0000644000176200001440000001337114712423107013230 0ustar liggesusers--- title: "S7 basics" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{S7 basics} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` The S7 package provides a new OOP system designed to be a successor to S3 and S4. It has been designed and implemented collaboratively by the RConsortium Object-Oriented Programming Working Group, which includes representatives from R-Core, BioConductor, RStudio/tidyverse, and the wider R community. This vignette gives an overview of the most important parts of S7: classes and objects, generics and methods, and the basics of method dispatch and inheritance. ```{r setup} library(S7) ``` ## Classes and objects S7 classes have a formal definition that you create with `new_class()`. There are two arguments that you'll use with almost every class: - The `name` of the class, supplied in the first argument. - The class `properties`, the data associated with each instance of the class. The easiest way to define properties is to supply a named list where the values define the valid types of the property. The following code defines a simple `dog` class with two properties: a character `name` and a numeric `age`. ```{r} Dog <- new_class("Dog", properties = list( name = class_character, age = class_numeric )) Dog ``` S7 provides a number of built-in definitions that allow you to refer to existing base types that are not S7 classes. You can recognize these definitions because they all start with `class_`. Note that I've assigned the return value of `new_class()` to an object with the same name as the class. This is important! That object represents the class and is what you use to construct instances of the class: ```{r} lola <- Dog(name = "Lola", age = 11) lola ``` Once you have an S7 object, you can get and set properties using `@`: ```{r} lola@age <- 12 lola@age ``` S7 automatically validates the type of the property using the type supplied in `new_class()`: ```{r, error = TRUE} lola@age <- "twelve" ``` Given an object, you can retrieves its class `S7_class()`: ```{r} S7_class(lola) ``` S7 objects also have an S3 `class()`. This is used for compatibility with existing S3 generics and you can learn more about it in `vignette("compatibility")`. ```{r} class(lola) ``` If you want to learn more about the details of S7 classes and objects, including validation methods and more details of properties, please see `vignette("classes-objects")`. ## Generics and methods S7, like S3 and S4, is built around the idea of **generic functions,** or **generics** for short. A generic defines an interface, which uses a different implementation depending on the class of one or more arguments. The implementation for a specific class is called a **method**, and the generic finds that appropriate method by performing **method dispatch**. Use `new_generic()` to create a S7 generic. In its simplest form, it only needs two arguments: the name of the generic (used in error messages) and the name of the argument used for method dispatch: ```{r} speak <- new_generic("speak", "x") ``` Like with `new_class()`, you should always assign the result of `new_generic()` to a variable with the same name as the first argument. Once you have a generic, you can register methods for specific classes with `method(generic, class) <- implementation`. ```{r} method(speak, Dog) <- function(x) { "Woof" } ``` Once the method is registered, the generic will use it when appropriate: ```{r} speak(lola) ``` Let's define another class, this one for cats, and define another method for `speak()`: ```{r} Cat <- new_class("Cat", properties = list( name = class_character, age = class_double )) method(speak, Cat) <- function(x) { "Meow" } fluffy <- Cat(name = "Fluffy", age = 5) speak(fluffy) ``` You get an error if you call the generic with a class that doesn't have a method: ```{r, error = TRUE} speak(1) ``` ## Method dispatch and inheritance The `cat` and `dog` classes share the same properties, so we could use a common parent class to extract out the duplicated specification. We first define the parent class: ```{r} Pet <- new_class("Pet", properties = list( name = class_character, age = class_numeric ) ) ``` Then use the `parent` argument to `new_class:` ```{r} Cat <- new_class("Cat", parent = Pet) Dog <- new_class("Dog", parent = Pet) Cat Dog ``` Because we have created new classes, we need to recreate the existing `lola` and `fluffy` objects: ```{r} lola <- Dog(name = "Lola", age = 11) fluffy <- Cat(name = "Fluffy", age = 5) ``` Method dispatch takes advantage of the hierarchy of parent classes: if a method is not defined for a class, it will try the method for the parent class, and so on until it finds a method or gives up with an error. This inheritance is a powerful mechanism for sharing code across classes. ```{r} describe <- new_generic("describe", "x") method(describe, Pet) <- function(x) { paste0(x@name, " is ", x@age, " years old") } describe(lola) describe(fluffy) method(describe, Dog) <- function(x) { paste0(x@name, " is a ", x@age, " year old dog") } describe(lola) describe(fluffy) ``` You can define a fallback method for any S7 object by registering a method for `S7_object`: ```{r} method(describe, S7_object) <- function(x) { "An S7 object" } Cocktail <- new_class("Cocktail", properties = list( ingredients = class_character ) ) martini <- Cocktail(ingredients = c("gin", "vermouth")) describe(martini) ``` Printing a generic will show you which methods are currently defined: ```{r} describe ``` And you can use `method()` to retrieve the implementation of one of those methods: ```{r} method(describe, Pet) ``` Learn more about method dispatch in `vignette("generics-methods")`. S7/inst/doc/generics-methods.R0000644000176200001440000001065514712722340015661 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(S7) ## ----------------------------------------------------------------------------- mean <- new_generic("mean", "x") method(mean, class_numeric) <- function(x) sum(x) / length(x) ## ----error = TRUE, eval = FALSE----------------------------------------------- # mean(100, na.rm = TRUE) ## ----------------------------------------------------------------------------- method(mean, class_numeric) <- function(x, na.rm = TRUE) { if (na.rm) { x <- x[!is.na(x)] } sum(x) / length(x) } mean(c(100, NA), na.rm = TRUE) ## ----------------------------------------------------------------------------- simple_print <- new_generic("simple_print", "x") method(simple_print, class_double) <- function(x, digits = 3) {} method(simple_print, class_character) <- function(x, max_length = 100) {} ## ----------------------------------------------------------------------------- method(simple_print, class_list) <- function(x, ...) { for (el in x) { simple_print(el, ...) } } ## ----error = TRUE, eval = FALSE----------------------------------------------- # simple_print(list(1, 2, 3), digits = 3) # simple_print(list(1, 2, "x"), digits = 3) ## ----------------------------------------------------------------------------- method(simple_print, class_double) <- function(x, ..., digits = 3) {} method(simple_print, class_character) <- function(x, ..., max_length = 100) {} simple_print(list(1, 2, "x"), digits = 3) ## ----------------------------------------------------------------------------- simple_print(list(1, 2, "x"), diggits = 3) ## ----eval = FALSE------------------------------------------------------------- # length <- new_generic("length", "x", function(x) { # S7_dispatch() # }) ## ----------------------------------------------------------------------------- display <- new_generic("display", "x") S7_data(display) ## ----------------------------------------------------------------------------- foo <- new_generic("foo", "x", function(x, y, ...) { S7_dispatch() }) ## ----------------------------------------------------------------------------- method(foo, class_integer) <- function(x, ...) { 10 } ## ----------------------------------------------------------------------------- mean <- new_generic("mean", "x", function(x, ..., na.rm = TRUE) { S7_dispatch() }) method(mean, class_integer) <- function(x, na.rm = TRUE) { if (na.rm) { x <- x[!is.na(x)] } sum(x) / length(x) } ## ----------------------------------------------------------------------------- method(mean, class_double) <- function(x, na.rm = FALSE) {} method(mean, class_logical) <- function(x) {} ## ----------------------------------------------------------------------------- mean <- new_generic("mean", "x", function(x, ..., na.rm = TRUE) { if (!identical(na.rm, TRUE) && !identical(na.rm = FALSE)) { stop("`na.rm` must be either TRUE or FALSE") } S7_dispatch() }) ## ----------------------------------------------------------------------------- mean <- new_generic("mean", "x") method(mean, class_numeric) <- function(x) { sum(x) / length(x) } mean(1:10) ## ----------------------------------------------------------------------------- date <- new_class("date", parent = class_double) # Cheat by using the existing base .Date class method(print, date) <- function(x) print(.Date(x)) date(c(1, 10, 100)) ## ----------------------------------------------------------------------------- method(mean, date) <- function(x) { date(mean(super(x, to = class_double))) } mean(date(c(1, 10, 100))) ## ----------------------------------------------------------------------------- Pet <- new_class("Pet") Dog <- new_class("Dog", Pet) Cat <- new_class("Cat", Pet) Language <- new_class("Language") English <- new_class("English", Language) French <- new_class("French", Language) speak <- new_generic("speak", c("x", "y")) method(speak, list(Dog, English)) <- function(x, y) "Woof" method(speak, list(Cat, English)) <- function(x, y) "Meow" method(speak, list(Dog, French)) <- function(x, y) "Ouaf Ouaf" method(speak, list(Cat, French)) <- function(x, y) "Miaou" speak(Cat(), English()) speak(Dog(), French()) # This example was originally inspired by blog.klipse.tech/javascript/2021/10/03/multimethod.html # which has unfortunately since disappeared. S7/inst/doc/classes-objects.html0000644000176200001440000015221214712722336016251 0ustar liggesusers Classes and objects

Classes and objects

This vignette dives into the details of S7 classes and objects, building on the basics discussed in vignette("S7"). It will cover validators, the finer details of properties, and finally how to write your own constructors.

library(S7)

Validation

S7 classes can have an optional validator that checks that the values of the properties are OK. A validator is a function that takes the object (called self) and returns NULL if its valid or returns a character vector listing the problems.

Basics

In the following example we create a Range class that enforces that @start and @end are single numbers, and that @start is less than @end:

Range <- new_class("Range",
  properties = list(
    start = class_double,
    end = class_double
  ),
  validator = function(self) {
    if (length(self@start) != 1) {
      "@start must be length 1"
    } else if (length(self@end) != 1) {
      "@end must be length 1"
    } else if (self@end < self@start) {
      sprintf(
        "@end (%i) must be greater than or equal to @start (%i)",
        self@end,
        self@start
      )
    }
  }
)

You can typically write a validator as a series of if-else statements, but note that the order of the statements is important. For example, in the code above, we can’t check that self@end < self@start before we’ve checked that @start and @end are length 1.

As we’ll discuss shortly, you can also perform validation on a per-property basis, so generally class validators should be reserved for interactions between properties.

When is validation performed?

Objects are validated automatically when constructed and when any property is modified:

x <- Range(1, 2:3)
#> Error: <Range> object properties are invalid:
#> - @end must be <double>, not <integer>
x <- Range(10, 1)
#> Error: <Range> object is invalid:
#> - @end (1) must be greater than or equal to @start (10)

x <- Range(1, 10)
x@start <- 20
#> Error: <Range> object is invalid:
#> - @end (10) must be greater than or equal to @start (20)

You can also manually validate() an object if you use a low-level R function to bypass the usual checks and balances of @:

x <- Range(1, 2)
attr(x, "start") <- 3
validate(x)
#> Error: <Range> object is invalid:
#> - @end (2) must be greater than or equal to @start (3)

Avoiding validation

Imagine you wanted to write a function that would shift a property to the left or the right:

shift <- function(x, shift) {
  x@start <- x@start + shift
  x@end <- x@end + shift
  x
}
shift(Range(1, 10), 1)
#> <Range>
#>  @ start: num 2
#>  @ end  : num 11

There’s a problem if shift is larger than @end - @start:

shift(Range(1, 10), 10)
#> Error: <Range> object is invalid:
#> - @end (10) must be greater than or equal to @start (11)

While the end result of shift() will be valid, an intermediate state is not. The easiest way to resolve this problem is to set the properties all at once:

shift <- function(x, shift) {
  props(x) <- list(
    start = x@start + shift,
    end = x@end + shift
  )
  x
}
shift(Range(1, 10), 10)
#> <Range>
#>  @ start: num 11
#>  @ end  : num 20

The object is still validated, but it’s only validated once, after all the properties have been modified.

Properties

So far we’ve focused on the simplest form of property specification where you use a named list to supply the desired type for each property. This is a convenient shorthand for a call to new_property(). For example, the property definition of range above is shorthand for:

Range <- new_class("Range",
  properties = list(
    start = new_property(class_double),
    end = new_property(class_double)
  )
)

Calling new_property() explicitly allows you to control aspects of the property other than its type. The following sections show you how to add a validator, provide a default value, compute the property value on demand, or provide a fully dynamic property.

Validation

You can optionally provide a validator for each property. For example, instead of validating the length of start and end in the validator of our Range class, we could implement those at the property level:

prop_number <- new_property(
  class = class_double,
  validator = function(value) {
    if (length(value) != 1L) "must be length 1"
  }
)

Range <- new_class("Range",
  properties = list(
    start = prop_number,
    end = prop_number
  ),
  validator = function(self) {
    if (self@end < self@start) {
      sprintf(
        "@end (%i) must be greater than or equal to @start (%i)",
        self@end,
        self@start
      )
    }
  }
)

Range(start = c(1.5, 3.5))
#> Error: <Range> object properties are invalid:
#> - @start must be length 1
#> - @end must be length 1
Range(end = c(1.5, 3.5))
#> Error: <Range> object properties are invalid:
#> - @start must be length 1
#> - @end must be length 1

Note that property validators shouldn’t include the name of the property in validation messages as S7 will add it automatically. This makes it possible to use the same property definition for multiple properties of the same type, as above.

Default value

The defaults of new_class() create an class that can be constructed with no arguments:

Empty <- new_class("Empty",
  properties = list(
    x = class_double,
    y = class_character,
    z = class_logical
  ))
Empty()
#> <Empty>
#>  @ x: num(0) 
#>  @ y: chr(0) 
#>  @ z: logi(0)

The default values of the properties will be filled in with “empty†instances. You can instead provide your own defaults by using the default argument:

Empty <- new_class("Empty",
  properties = list(
    x = new_property(class_numeric, default = 0),
    y = new_property(class_character, default = ""),
    z = new_property(class_logical, default = NA)
  )
)
Empty()
#> <Empty>
#>  @ x: num 0
#>  @ y: chr ""
#>  @ z: logi NA

A quoted call becomes a standard function promise in the default constructor, evaluated at the time the object is constructed.

Stopwatch <- new_class("Stopwatch", properties = list(
  start_time = new_property(
    class = class_POSIXct,
    default = quote(Sys.time())
  ),
  elapsed = new_property(
    getter = function(self) {
      difftime(Sys.time(), self@start_time, units = "secs")
    }
  )
))
args(Stopwatch)
#> function (start_time = Sys.time()) 
#> NULL
round(Stopwatch()@elapsed)
#> Time difference of 0 secs
round(Stopwatch(Sys.time() - 1)@elapsed)
#> Time difference of 1 secs

Computed properties

It’s sometimes useful to have a property that is computed on demand. For example, it’d be convenient to pretend that our range has a length, which is just the distance between @start and @end. You can dynamically compute the value of a property by defining a getter:

Range <- new_class("Range",
  properties = list(
    start = class_double,
    end = class_double,
    length = new_property(
      getter = function(self) self@end - self@start,
    )
  )
)

x <- Range(start = 1, end = 10)
x
#> <Range>
#>  @ start : num 1
#>  @ end   : num 10
#>  @ length: num 9

Computed properties are read-only:

x@length <- 20
#> Error: Can't set read-only property <Range>@length

Dynamic properties

You can make a computed property fully dynamic so that it can be read and written by also supplying a setter.

A setter is a function with arguments self and value that returns a modified object.

For example, we could extend the previous example to allow the @length to be set, by modifying the @end of the vector:

Range <- new_class("Range",
  properties = list(
    start = class_double,
    end = class_double,
    length = new_property(
      class = class_double,
      getter = function(self) self@end - self@start,
      setter = function(self, value) {
        self@end <- self@start + value
        self
      }
    )
  )
)

x <- Range(start = 1, end = 10)
x
#> <Range>
#>  @ start : num 1
#>  @ end   : num(0) 
#>  @ length: num(0)

x@length <- 5
x
#> <Range>
#>  @ start : num 1
#>  @ end   : num 6
#>  @ length: num 5

Common Patterns

getter, setter, default, and validator can be used to implement many common patterns of properties.

Deprecated properties

A setter + getter can be used to to deprecate a property:

Person <- new_class("Person", properties = list(
 first_name = class_character,
 firstName = new_property(
    class_character,
    default = quote(first_name),
    getter = function(self) {
      warning("@firstName is deprecated; please use @first_name instead", call. = FALSE)
      self@first_name
    },
    setter = function(self, value) {
      if (identical(value, self@first_name)) {
        return(self)
      }
      warning("@firstName is deprecated; please use @first_name instead", call. = FALSE)
      self@first_name <- value
      self
    }
  )
))

args(Person)
#> function (first_name = character(0), firstName = first_name) 
#> NULL

hadley <- Person(firstName = "Hadley")
#> Warning: @firstName is deprecated; please use @first_name instead

hadley <- Person(first_name = "Hadley") # no warning

hadley@firstName
#> Warning: @firstName is deprecated; please use @first_name instead
#> [1] "Hadley"

hadley@firstName <- "John"
#> Warning: @firstName is deprecated; please use @first_name instead

hadley@first_name  # no warning
#> [1] "John"

Required properties

You can make a property required by the constructor either by:

  • relying on the validator to error with the default value, or by
  • setting the property default to a quoted error call.
Person <- new_class("Person", properties = list(
 name = new_property(
   class_character,
   validator = function(value) {
     if (length(value) != 1 || is.na(value) || value == "")
       "must be a non-empty string"
   }
 )
))

try(Person())
#> Error : <Person> object properties are invalid:
#> - @name must be a non-empty string

try(Person(1)) # class_character$validator() is also checked.
#> Error : <Person> object properties are invalid:
#> - @name must be <character>, not <double>

Person("Alice")
#> <Person>
#>  @ name: chr "Alice"
Person <- new_class("Person", properties = list(
 name = new_property(
   class_character,
   default = quote(stop("@name is required")))
))

try(Person())
#> Error in Person() : @name is required

Person("Alice")
#> <Person>
#>  @ name: chr "Alice"

Frozen properties

You can mark a property as read-only after construction by providing a custom setter.

Person <- new_class("Person", properties = list(
 birth_date = new_property(
   class_Date,
   setter = function(self, value) {
     if(!is.null(self@birth_date)) {
       stop("@birth_date is read-only", call. = FALSE)
     }
     self@birth_date <- as.Date(value)
     self
   }
)))

person <- Person("1999-12-31")

try(person@birth_date <- "2000-01-01")
#> Error : @birth_date is read-only

Constructors

You can see the source code for a class’s constructor by accessing the constructor property:

Range@constructor
#> function (start = numeric(0), end = numeric(0), length = numeric(0)) 
#> {
#>     start
#>     end
#>     length
#>     S7::new_object(S7::S7_object(), start = start, end = end, 
#>         length = length)
#> }

In most cases, S7’s default constructor will be all you need. However, in some cases you might want something custom. For example, for our range class, maybe we’d like to construct it from a vector of numeric values, automatically computing the min and the max. To implement this we could do:

Range <- new_class("Range",
  properties = list(
    start = class_numeric,
    end = class_numeric
  ),
  constructor = function(x) {
    new_object(S7_object(), 
               start = min(x, na.rm = TRUE), 
               end = max(x, na.rm = TRUE))
  }
)

range(c(10, 5, 0, 2, 5, 7))
#> [1]  0 10

A constructor must always end with a call to new_object(). The first argument to new_object() should be an object of the parent class (if you haven’t specified a parent argument to new_class(), then you should use S7_object() as the parent here). That argument should be followed by one named argument for each property.

There’s one drawback of custom constructors that you should be aware of: any subclass will also require a custom constructor.

S7/inst/doc/motivation.html0000644000176200001440000003221014712722340015344 0ustar liggesusers Motivation for S7

Motivation for S7

R already has two OO systems built-in (S3 and S4) and many additional OO systems are available in CRAN packages. Why did we decide more work was needed? This vignette will discuss some of the motivations behind S7, focussing on the aspects of S3 and S4 that have been found to be particularly challenging in practice.

library(S7)

Challenges with S3

  • S3 is very informal, meaning that there’s no formal definition of a class. This makes it impossible to know exactly which properties an object should or could possess, or even what its parent class should be. S7 resolves this problem with a formal definition encoded in a class object produced by new_class(). This includes support for validation (and avoiding validation where needed) as inspired by S4.

  • When a new user encounter an S3 generic, they are often confused because the implementation of the function appears to be missing. S7 has a thoughtfully designed print method that makes it clear what methods are available and how to find their source code.

  • Properties of an S3 class are usually stored in attributes, but, by default, attr() does partial matching, which can lead to bugs that are hard to diagnose. Additionally, attr() returns NULL if an attribute doesn’t exist, so misspelling an attribute can lead to subtle bugs. @ fixes both of these problems.

  • S3 method dispatch is complicated for compatibility with S. This complexity affects relatively little code, but when you attempt to dive into the details it makes UseMethod() hard to understand. As much as possible, S7 avoids any “funny†business with environments or promises, so that there is no distinction between argument values and local values.

  • S3 is primarily designed for single dispatch and double dispatch is only provided for a handful of base generics. It’s not possible to reuse the implementation for user generics. S7 provides a standard way of doing multiple dispatch (including double dispatch) that can be used for any generic.

  • NextMethod() is unpredictable since you can’t tell exactly which method will be called by only reading the code; you instead need to know both the complete class hierarchy and what other methods are currently registered (and loading a package might change those methods). S7 takes a difference approach with super(), requiring explicit specification of the superclass to be used.

  • Conversion between S3 classes is only implemented via loose convention: if you implement a class foo, then you should also provide generic as.foo() to convert other objects to that type. S7 avoids this problem by providing the double-dispatch convert() generic so that you only need to provide the appropriate methods.

Challenges with S4

  • Multiple inheritance seemed like a powerful idea at the time, but in practice it appears to generate more problems than it solves. S7 does not support multiple inheritance.

  • S4’s method dispatch uses a principled but complex distance metric to pick the best method in the presence of ambiguity. Time has shown that this approach is hard for people to understand and makes it hard to predict what will happen when new methods are registered. S7 implements a much simpler, greedy, approach that trades some additional work on behalf of the class author for a system that is simpler and easier to understand.

  • S4 is a clean break from S3. This made it possible to make radical changes but it made it harder to switch from S3 to S4, leading to a general lack of adoption in the R community. S7 is designed to be drop-in compatible with S3, making it possible to convert existing packages to use S7 instead of S3 with only an hour or two of work.

  • At least within Bioconductor, slots are generally thought of as implementation detail that should not be directly accessed by the end-user. This leads to two problems. Firstly, implementing an S4 Bioconductor class often also requires a plethora of accessor functions that are a thin wrapper around @ or @<-. Secondly, users know about @ and use it to access object internals even though they’re not supposed to. S7 avoids these problems by accepting the fact that R is a data language, and that there’s no way to stop users from pulling the data they need out of an object. To make it possible to change the internal implementation details of an object while preserving existing @ usage, S7 provides dynamic properties.
S7/inst/doc/generics-methods.html0000644000176200001440000010667014712722340016427 0ustar liggesusers Generics and methods

Generics and methods

This vignette dives into the details of S7 generics and method dispatch, building on the basics discussed in vignette("S7"). We’ll first introduce the concept of generic-method compatibility, then discuss some of the finer details of creating a generic with new_generic(). This vignette first discusses generic-method compatibility, and you might want to customize the body of the generic, and generics that live in suggested packages. We’ll then pivot to talk more details of method dispatch including super() and multiple dispatch.

library(S7)

Generic-method compatibility

When you register a method, S7 checks that your method is compatible with the generic.

The formal arguments of the generic and methods must agree. This means that:

  • Any arguments that the generic has, the method must have too. In particular, the arguments of the method start with the arguments that the generic dispatches on, and those arguments must not have default arguments.
  • The method can contain arguments that the generic does not, as long as the generic includes … in the argument list.

Generic with dots; method without dots

The default generic includes … but generally the methods should not. That ensures that misspelled arguments won’t be silently swallowed by the method. This is an important difference from S3. Take a very simple implementation of mean():

mean <- new_generic("mean", "x")
method(mean, class_numeric) <- function(x) sum(x) / length(x)

If we pass an additional argument in, we’ll get an error:

mean(100, na.rm = TRUE)

But we can still add additional arguments if we desired:

method(mean, class_numeric) <- function(x, na.rm = TRUE) {
  if (na.rm) {
    x <- x[!is.na(x)]
  }

  sum(x) / length(x)
}
#> Overwriting method mean(<integer>)
#> Overwriting method mean(<double>)
mean(c(100, NA), na.rm = TRUE)
#> [1] 100

(We’ll come back to the case of requiring that all methods implement a na.rm = TRUE argument shortly.)

Generic and method with dots

There are cases where you do need to take … in a method, which is particularly problematic if you need to re-call the generic recursively. For example, imagine a simple print method like this:

simple_print <- new_generic("simple_print", "x")
method(simple_print, class_double) <- function(x, digits = 3) {}
method(simple_print, class_character) <- function(x, max_length = 100) {}

What if you want to print a list?

method(simple_print, class_list) <- function(x, ...) {
  for (el in x) {
    simple_print(el, ...)
  }
}

It’s fine as long as all the elements of the list are numbers, but as soon as we add a character vector, we get an error:

simple_print(list(1, 2, 3), digits = 3)
simple_print(list(1, 2, "x"), digits = 3)

To solve this situation, methods generally need to ignore arguments that they haven’t been specifically designed to handle, i.e. they need to use …:

method(simple_print, class_double) <- function(x, ..., digits = 3) {}
#> Overwriting method simple_print(<double>)
method(simple_print, class_character) <- function(x, ..., max_length = 100) {}
#> Overwriting method simple_print(<character>)

simple_print(list(1, 2, "x"), digits = 3)

In this case we really do want to silently ignore unknown arguments because they might apply to other methods. There’s unfortunately no easy way to avoid this problem without relying on fairly esoteric technology (as done by rlang::check_dots_used()).

simple_print(list(1, 2, "x"), diggits = 3)

Generic and method without dots

Occasional it’s useful to create a generic without … because such functions have a useful property: if a call succeeds for one type of input, it will succeed for any type of input. To create such a generic, you’ll need to use the third argument to new_generic(): an optional function that powers the generic. This function has one key property: it must call call_method() to actually perform dispatch.

In general, this property is only needed for very low-level functions with precisely defined semantics. A good example of such a function is length():

length <- new_generic("length", "x", function(x) {
  S7_dispatch()
})

Omitting … from the generic signature is a strong restriction as it prevents methods from adding extra arguments. For this reason, it’s should only be used in special situations.

Customizing generics

In most cases, you’ll supply the first two arguments to new_generic() and allow it to automatically generate the body of the generic:

display <- new_generic("display", "x")
S7_data(display)
#> function (x, ...) 
#> S7::S7_dispatch()

The most important part of the body is S7_dispatch(); this function finds the method the matches the arguments used for dispatch and calls it with the arguments supplied to the generic.

It can be useful to customize this body. The previous section showed one case when you might want to supply the body yourself: dropping … from the formals of the generic. There are three other useful cases:

  • To add required arguments.
  • To add optional arguments.
  • Perform some standard work.

A custom fun must always include a call to call_method(), which will usually be the last call.

Add required arguments

To add required arguments that aren’t dispatched upon, you just need to add additional arguments that lack default values:

foo <- new_generic("foo", "x", function(x, y, ...) {
  S7_dispatch()
})

Now all methods will need to provide that y argument. If not, you’ll get a warning:

method(foo, class_integer) <- function(x, ...) {
  10
}
#> Warning: foo(<integer>) doesn't have argument `y`

This is a warning, not an error, because the generic might be defined in a different package and is in the process of changing interfaces. You’ll always want to address this warning when you see it.

Add optional arguments

Adding an optional argument is similar, but it should generally come after …. This ensures that the user must supply the full name of the argument when calling the function, which makes it easier to extend your function in the future.

mean <- new_generic("mean", "x", function(x, ..., na.rm = TRUE) {
  S7_dispatch()
})
method(mean, class_integer) <- function(x, na.rm = TRUE) {
  if (na.rm) {
    x <- x[!is.na(x)]
  }
  sum(x) / length(x)
}

Forgetting the argument or using a different default value will again generate a warning.

method(mean, class_double) <- function(x, na.rm = FALSE) {}
#> Warning: In mean(<double>), default value of `na.rm` is not the same as the generic
#> - Generic: TRUE
#> - Method:  FALSE
method(mean, class_logical) <- function(x) {}
#> Warning: mean(<logical>) doesn't have argument `na.rm`

Do some work

If your generic has additional arguments, you might want to do some additional work to verify that they’re of the expected type. For example, our mean() function could verify that na.rm was correctly specified:

mean <- new_generic("mean", "x", function(x, ..., na.rm = TRUE) {
  if (!identical(na.rm, TRUE) && !identical(na.rm = FALSE)) {
    stop("`na.rm` must be either TRUE or FALSE")
  }
  S7_dispatch()
})

The only downside to performing error checking is that you constraint the interface for all methods; if for some reason a method found it useful to allow na.rm to be a number or a string, it would have to provide an alternative argument.

super()

Sometimes it’s useful to define a method for in terms of its superclass. A good example of this is computing the mean of a date — since dates represent the number of days since 1970-01-01, computing the mean is just a matter of computing the mean of the underlying numeric vector and converting it back to a date.

To demonstrate this idea, I’ll first define a mean generic with a method for numbers:

mean <- new_generic("mean", "x")
method(mean, class_numeric) <- function(x) {
  sum(x) / length(x)
}
mean(1:10)
#> [1] 5.5

And a Date class:

date <- new_class("date", parent = class_double)
# Cheat by using the existing base .Date class
method(print, date) <- function(x) print(.Date(x))
date(c(1, 10, 100))
#> [1] "1970-01-02" "1970-01-11" "1970-04-11"

Now to compute a mean we write:

method(mean, date) <- function(x) {
  date(mean(super(x, to = class_double)))
}
mean(date(c(1, 10, 100)))
#> [1] "1970-02-07"

Let’s unpack this method from the inside out:

  1. First we call super(x, to = class_double) — this will make the call to next generic treat x like it’s a double, rather than a date.
  2. Then we call mean() which because of super() will call the mean() method we defined above.
  3. Finally, we take the number returned by mean and convert it back to a date.

If you’re very familiar with S3 or S4 you might recognize that super() fills a similar role to NextMethod() or callNextMethod(). However, it’s much more explicit: you need to supply the name of the parent class, the generic to use, and all the arguments to the generic. This explicitness makes the code easier to understand and will eventually enable certain performance optimizations that would otherwise be very difficult.

Multiple dispatch

So far we have focused primarily on single dispatch, i.e. generics where dispatch_on is a single string. It is also possible to supply a length 2 (or more!) vector dispatch_on to create a generic that performs multiple dispatch, i.e. it uses the classes of more than one object to find the appropriate method.

Multiple dispatch is a feature primarily of S4, although S3 includes some limited special cases for arithmetic operators. Multiple dispatch is heavily used in S4; we don’t expect it to be heavily used in S7, but it is occasionally useful.

A simple example

Let’s take our speak example from vignette("S7") and extend it to teach our pets how to speak multiple languages:

Pet <- new_class("Pet")
Dog <- new_class("Dog", Pet)
Cat <- new_class("Cat", Pet)

Language <- new_class("Language")
English <- new_class("English", Language)
French <- new_class("French", Language)

speak <- new_generic("speak", c("x", "y"))
method(speak, list(Dog, English)) <- function(x, y) "Woof"
method(speak, list(Cat, English)) <- function(x, y) "Meow"
method(speak, list(Dog, French)) <- function(x, y) "Ouaf Ouaf"
method(speak, list(Cat, French)) <- function(x, y) "Miaou"

speak(Cat(), English())
#> [1] "Meow"
speak(Dog(), French())
#> [1] "Ouaf Ouaf"

# This example was originally inspired by blog.klipse.tech/javascript/2021/10/03/multimethod.html
# which has unfortunately since disappeared.

Special “classesâ€

There are two special classes that become particularly useful with multiple dispatch:

  • class_any() will match any class
  • class_missing() will match a missing argument (i.e. not NA, but an argument that was not supplied)
S7/inst/doc/packages.html0000644000176200001440000003075614712722341014747 0ustar liggesusers Using S7 in a package

Using S7 in a package

This vignette outlines the most important things you need to know about using S7 in a package. S7 is new, so few people have used it in a package yet; this means that this vignette is likely incomplete, and we’d love your help to make it better. Please let us know if you have questions that this vignette doesn’t answer.

library(S7)

Method registration

You should always call methods_register() in your .onLoad():

.onLoad <- function(...) {
  S7::methods_register()
}

This is S7’s way of registering methods, rather than using export directives in your NAMESPACE like S3 and S4 do. This is only strictly necessary if registering methods for generics in other packages, but there’s no harm in adding it and it ensures that you won’t forget later. (And if you’re not importing S7 into your namespace it will quiet an R CMD check NOTE.)

Documentation and exports

If you want users to create instances of your class, you will need to export the class constructor. That means you will also need to document it, and since the constructor is a function, that means you have to document the arguments which will be the properties of the class (unless you have customised the constructor).

If you export a class, you must also set the package argument, ensuring that classes with the same name are disambiguated across packages.

You should document generics like regular functions (since they are!). If you expect others to create their own methods for your generic, you may want to include an section describing the the properties that you expect all methods to have. We plan to provide a an easy way to all methods for a generic, but have not yet implemented it. You can track progress at https://github.com/RConsortium/S7/issues/167.

We don’t currently have any recommendations on documenting methods. There’s no need to document them in order to pass R CMD check, but obviously there are cases where it’s nice to provide additional details for a method, particularly if it takes extra arguments compared to the generic. We’re tracking that issue at https://github.com/RConsortium/S7/issues/315.

Backward compatibility

If you are using S7 in a package and you want your package to work in versions of R before 4.3.0, you need to know that in these versions of R @ only works with S4 objects. There are two workarounds. The easiest and least convenient workaround is to just prop() instead of @. Otherwise, you can conditionally make an S7-aware @ available to your package with this custom NAMESPACE directive:

# enable usage of <S7_object>@name in package code
#' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@")
NULL

@ will work for users of your package because S7 automatically attaches an environment containing the needed definition when it’s loaded.

S7/inst/doc/performance.Rmd0000644000176200001440000001131614712423107015235 0ustar liggesusers--- title: "Performance" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Performance} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(S7) ``` The dispatch performance should be roughly on par with S3 and S4, though as this is implemented in a package there is some overhead due to `.Call` vs `.Primitive`. ```{r performance, cache = FALSE} Text <- new_class("Text", parent = class_character) Number <- new_class("Number", parent = class_double) x <- Text("hi") y <- Number(1) foo_S7 <- new_generic("foo_S7", "x") method(foo_S7, Text) <- function(x, ...) paste0(x, "-foo") foo_S3 <- function(x, ...) { UseMethod("foo_S3") } foo_S3.Text <- function(x, ...) { paste0(x, "-foo") } library(methods) setOldClass(c("Number", "numeric", "S7_object")) setOldClass(c("Text", "character", "S7_object")) setGeneric("foo_S4", function(x, ...) standardGeneric("foo_S4")) setMethod("foo_S4", c("Text"), function(x, ...) paste0(x, "-foo")) # Measure performance of single dispatch bench::mark(foo_S7(x), foo_S3(x), foo_S4(x)) bar_S7 <- new_generic("bar_S7", c("x", "y")) method(bar_S7, list(Text, Number)) <- function(x, y, ...) paste0(x, "-", y, "-bar") setGeneric("bar_S4", function(x, y, ...) standardGeneric("bar_S4")) setMethod("bar_S4", c("Text", "Number"), function(x, y, ...) paste0(x, "-", y, "-bar")) # Measure performance of double dispatch bench::mark(bar_S7(x, y), bar_S4(x, y)) ``` A potential optimization is caching based on the class names, but lookup should be fast without this. The following benchmark generates a class hierarchy of different levels and lengths of class names and compares the time to dispatch on the first class in the hierarchy vs the time to dispatch on the last class. We find that even in very extreme cases (e.g. 100 deep hierarchy 100 of character class names) the overhead is reasonable, and for more reasonable cases (e.g. 10 deep hierarchy of 15 character class names) the overhead is basically negligible. ```{r performance-2, message = FALSE, R.options = list(width = 120), cache = TRUE} library(S7) gen_character <- function (n, min = 5, max = 25, values = c(letters, LETTERS, 0:9)) { lengths <- sample(min:max, replace = TRUE, size = n) values <- sample(values, sum(lengths), replace = TRUE) starts <- c(1, cumsum(lengths)[-n] + 1) ends <- cumsum(lengths) mapply(function(start, end) paste0(values[start:end], collapse=""), starts, ends) } bench::press( num_classes = c(3, 5, 10, 50, 100), class_nchar = c(15, 100), { # Construct a class hierarchy with that number of classes Text <- new_class("Text", parent = class_character) parent <- Text classes <- gen_character(num_classes, min = class_nchar, max = class_nchar) env <- new.env() for (x in classes) { assign(x, new_class(x, parent = parent), env) parent <- get(x, env) } # Get the last defined class cls <- parent # Construct an object of that class x <- do.call(cls, list("hi")) # Define a generic and a method for the last class (best case scenario) foo_S7 <- new_generic("foo_S7", "x") method(foo_S7, cls) <- function(x, ...) paste0(x, "-foo") # Define a generic and a method for the first class (worst case scenario) foo2_S7 <- new_generic("foo2_S7", "x") method(foo2_S7, S7_object) <- function(x, ...) paste0(x, "-foo") bench::mark( best = foo_S7(x), worst = foo2_S7(x) ) } ) ``` And the same benchmark using double-dispatch ```{r performance-3, message = FALSE, R.options = list(width = 120), cache = TRUE} bench::press( num_classes = c(3, 5, 10, 50, 100), class_nchar = c(15, 100), { # Construct a class hierarchy with that number of classes Text <- new_class("Text", parent = class_character) parent <- Text classes <- gen_character(num_classes, min = class_nchar, max = class_nchar) env <- new.env() for (x in classes) { assign(x, new_class(x, parent = parent), env) parent <- get(x, env) } # Get the last defined class cls <- parent # Construct an object of that class x <- do.call(cls, list("hi")) y <- do.call(cls, list("ho")) # Define a generic and a method for the last class (best case scenario) foo_S7 <- new_generic("foo_S7", c("x", "y")) method(foo_S7, list(cls, cls)) <- function(x, y, ...) paste0(x, y, "-foo") # Define a generic and a method for the first class (worst case scenario) foo2_S7 <- new_generic("foo2_S7", c("x", "y")) method(foo2_S7, list(S7_object, S7_object)) <- function(x, y, ...) paste0(x, y, "-foo") bench::mark( best = foo_S7(x, y), worst = foo2_S7(x, y) ) } ) ``` S7/inst/doc/compatibility.R0000644000176200001440000000327414712722337015277 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(S7) ## ----------------------------------------------------------------------------- Foo <- new_class("Foo") class(Foo()) mean.Foo <- function(x, ...) { "mean of foo" } mean(Foo()) ## ----------------------------------------------------------------------------- rle <- function(x) { if (!is.vector(x) && !is.list(x)) { stop("'x' must be a vector of an atomic type") } n <- length(x) if (n == 0L) { new_rle(integer(), x) } else { y <- x[-1L] != x[-n] i <- c(which(y | is.na(y)), n) new_rle(diff(c(0L, i)), x[i]) } } new_rle <- function(lengths, values) { structure( list( lengths = lengths, values = values ), class = "rle" ) } ## ----------------------------------------------------------------------------- new_rle <- new_class("rle", parent = class_list, constructor = function(lengths, values) { new_object(list(lengths = lengths, values = values)) } ) rle(1:10) ## ----------------------------------------------------------------------------- rle <- new_class("rle", properties = list( lengths = class_integer, values = class_atomic )) ## ----------------------------------------------------------------------------- method(`$`, rle) <- prop rle(1:10) ## ----------------------------------------------------------------------------- Class1 <- new_class("Class1") Class2 <- new_class("Class2") Union1 <- new_union(Class1, Class2) foo <- new_generic("foo", "x") method(foo, Union1) <- function(x) "" foo S7/inst/doc/motivation.R0000644000176200001440000000035514712722340014606 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(S7) S7/inst/doc/classes-objects.Rmd0000644000176200001440000002461314712423107016024 0ustar liggesusers--- title: "Classes and objects" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Classes and objects} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` This vignette dives into the details of S7 classes and objects, building on the basics discussed in `vignette("S7")`. It will cover validators, the finer details of properties, and finally how to write your own constructors. ```{r setup} library(S7) ``` ## Validation S7 classes can have an optional **validator** that checks that the values of the properties are OK. A validator is a function that takes the object (called `self`) and returns `NULL` if its valid or returns a character vector listing the problems. ### Basics In the following example we create a `Range` class that enforces that `@start` and `@end` are single numbers, and that `@start` is less than `@end`: ```{r} Range <- new_class("Range", properties = list( start = class_double, end = class_double ), validator = function(self) { if (length(self@start) != 1) { "@start must be length 1" } else if (length(self@end) != 1) { "@end must be length 1" } else if (self@end < self@start) { sprintf( "@end (%i) must be greater than or equal to @start (%i)", self@end, self@start ) } } ) ``` You can typically write a validator as a series of `if`-`else` statements, but note that the order of the statements is important. For example, in the code above, we can't check that `self@end < self@start` before we've checked that `@start` and `@end` are length 1. As we'll discuss shortly, you can also perform validation on a per-property basis, so generally class validators should be reserved for interactions between properties. ### When is validation performed? Objects are validated automatically when constructed and when any property is modified: ```{r, error = TRUE} x <- Range(1, 2:3) x <- Range(10, 1) x <- Range(1, 10) x@start <- 20 ``` You can also manually `validate()` an object if you use a low-level R function to bypass the usual checks and balances of `@`: ```{r, error = TRUE} x <- Range(1, 2) attr(x, "start") <- 3 validate(x) ``` ### Avoiding validation Imagine you wanted to write a function that would shift a property to the left or the right: ```{r} shift <- function(x, shift) { x@start <- x@start + shift x@end <- x@end + shift x } shift(Range(1, 10), 1) ``` There's a problem if `shift` is larger than `@end` - `@start`: ```{r, error = TRUE} shift(Range(1, 10), 10) ``` While the end result of `shift()` will be valid, an intermediate state is not. The easiest way to resolve this problem is to set the properties all at once: ```{r} shift <- function(x, shift) { props(x) <- list( start = x@start + shift, end = x@end + shift ) x } shift(Range(1, 10), 10) ``` The object is still validated, but it's only validated once, after all the properties have been modified. ## Properties So far we've focused on the simplest form of property specification where you use a named list to supply the desired type for each property. This is a convenient shorthand for a call to `new_property()`. For example, the property definition of range above is shorthand for: ```{r} Range <- new_class("Range", properties = list( start = new_property(class_double), end = new_property(class_double) ) ) ``` Calling `new_property()` explicitly allows you to control aspects of the property other than its type. The following sections show you how to add a validator, provide a default value, compute the property value on demand, or provide a fully dynamic property. ### Validation You can optionally provide a validator for each property. For example, instead of validating the length of `start` and `end` in the validator of our `Range` class, we could implement those at the property level: ```{r, error = TRUE} prop_number <- new_property( class = class_double, validator = function(value) { if (length(value) != 1L) "must be length 1" } ) Range <- new_class("Range", properties = list( start = prop_number, end = prop_number ), validator = function(self) { if (self@end < self@start) { sprintf( "@end (%i) must be greater than or equal to @start (%i)", self@end, self@start ) } } ) Range(start = c(1.5, 3.5)) Range(end = c(1.5, 3.5)) ``` Note that property validators shouldn't include the name of the property in validation messages as S7 will add it automatically. This makes it possible to use the same property definition for multiple properties of the same type, as above. ### Default value The defaults of `new_class()` create an class that can be constructed with no arguments: ```{r} Empty <- new_class("Empty", properties = list( x = class_double, y = class_character, z = class_logical )) Empty() ``` The default values of the properties will be filled in with "empty" instances. You can instead provide your own defaults by using the `default` argument: ```{r} Empty <- new_class("Empty", properties = list( x = new_property(class_numeric, default = 0), y = new_property(class_character, default = ""), z = new_property(class_logical, default = NA) ) ) Empty() ``` A quoted call becomes a standard function promise in the default constructor, evaluated at the time the object is constructed. ```{r} Stopwatch <- new_class("Stopwatch", properties = list( start_time = new_property( class = class_POSIXct, default = quote(Sys.time()) ), elapsed = new_property( getter = function(self) { difftime(Sys.time(), self@start_time, units = "secs") } ) )) args(Stopwatch) round(Stopwatch()@elapsed) round(Stopwatch(Sys.time() - 1)@elapsed) ``` ### Computed properties It's sometimes useful to have a property that is computed on demand. For example, it'd be convenient to pretend that our range has a length, which is just the distance between `@start` and `@end`. You can dynamically compute the value of a property by defining a `getter`: ```{r} Range <- new_class("Range", properties = list( start = class_double, end = class_double, length = new_property( getter = function(self) self@end - self@start, ) ) ) x <- Range(start = 1, end = 10) x ``` Computed properties are read-only: ```{r, error = TRUE} x@length <- 20 ``` ### Dynamic properties You can make a computed property fully dynamic so that it can be read and written by also supplying a `setter`. A `setter` is a function with arguments `self` and `value` that returns a modified object. For example, we could extend the previous example to allow the `@length` to be set, by modifying the `@end` of the vector: ```{r} Range <- new_class("Range", properties = list( start = class_double, end = class_double, length = new_property( class = class_double, getter = function(self) self@end - self@start, setter = function(self, value) { self@end <- self@start + value self } ) ) ) x <- Range(start = 1, end = 10) x x@length <- 5 x ``` ### Common Patterns `getter`, `setter`, `default`, and `validator` can be used to implement many common patterns of properties. #### Deprecated properties A `setter` + `getter` can be used to to deprecate a property: ```{r} Person <- new_class("Person", properties = list( first_name = class_character, firstName = new_property( class_character, default = quote(first_name), getter = function(self) { warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) self@first_name }, setter = function(self, value) { if (identical(value, self@first_name)) { return(self) } warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) self@first_name <- value self } ) )) args(Person) hadley <- Person(firstName = "Hadley") hadley <- Person(first_name = "Hadley") # no warning hadley@firstName hadley@firstName <- "John" hadley@first_name # no warning ``` #### Required properties You can make a property required by the constructor either by: - relying on the validator to error with the default value, or by - setting the property default to a quoted error call. ```{r} Person <- new_class("Person", properties = list( name = new_property( class_character, validator = function(value) { if (length(value) != 1 || is.na(value) || value == "") "must be a non-empty string" } ) )) try(Person()) try(Person(1)) # class_character$validator() is also checked. Person("Alice") ``` ```{r} Person <- new_class("Person", properties = list( name = new_property( class_character, default = quote(stop("@name is required"))) )) try(Person()) Person("Alice") ``` #### Frozen properties You can mark a property as read-only after construction by providing a custom `setter`. ```{r} Person <- new_class("Person", properties = list( birth_date = new_property( class_Date, setter = function(self, value) { if(!is.null(self@birth_date)) { stop("@birth_date is read-only", call. = FALSE) } self@birth_date <- as.Date(value) self } ))) person <- Person("1999-12-31") try(person@birth_date <- "2000-01-01") ``` ## Constructors You can see the source code for a class's constructor by accessing the `constructor` property: ```{r} Range@constructor ``` In most cases, S7's default constructor will be all you need. However, in some cases you might want something custom. For example, for our range class, maybe we'd like to construct it from a vector of numeric values, automatically computing the min and the max. To implement this we could do: ```{r} Range <- new_class("Range", properties = list( start = class_numeric, end = class_numeric ), constructor = function(x) { new_object(S7_object(), start = min(x, na.rm = TRUE), end = max(x, na.rm = TRUE)) } ) range(c(10, 5, 0, 2, 5, 7)) ``` A constructor must always end with a call to `new_object()`. The first argument to `new_object()` should be an object of the `parent` class (if you haven't specified a `parent` argument to `new_class()`, then you should use `S7_object()` as the parent here). That argument should be followed by one named argument for each property. There's one drawback of custom constructors that you should be aware of: any subclass will also require a custom constructor. S7/README.md0000644000176200001440000000770314712502457012040 0ustar liggesusers # S7 [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) [![R-CMD-check](https://github.com/RConsortium/S7/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/RConsortium/S7/actions/workflows/R-CMD-check.yaml) [![Codecov test coverage](https://codecov.io/gh/RConsortium/S7/branch/main/graph/badge.svg)](https://app.codecov.io/gh/RConsortium/S7?branch=main) The S7 package is a new OOP system designed to be a successor to S3 and S4. It has been designed and implemented collaboratively by the R Consortium Object-Oriented Programming Working Group, which includes representatives from R-Core, Bioconductor, the tidyverse/Posit, and the wider R community. S7 is somewhat experimental; we are confident in the design but it has relatively little usage in the wild currently. We hope to avoid any major breaking changes, but reserve the right if we discover major problems. ## Installation The long-term goal of this project is to merge S7 in to base R. For now, you can experiment by installing it from CRAN: ``` r install.packages("S7") ``` ## Usage This section gives a very brief overview of the entirety of S7. Learn more of the basics in `vignette("S7")`, generics and methods in `vignette("generics-methods")`, classes and objects in `vignette("classes-objects")`, and compatibility with S3 and S4 in `vignette("compatibility")`. ``` r library(S7) ``` ### Classes and objects S7 classes have a formal definition, which includes a list of properties and an optional validator. Use `new_class()` to define a class: ``` r range <- new_class("range", properties = list( start = class_double, end = class_double ), validator = function(self) { if (length(self@start) != 1) { "@start must be length 1" } else if (length(self@end) != 1) { "@end must be length 1" } else if (self@end < self@start) { "@end must be greater than or equal to @start" } } ) ``` `new_class()` returns the class object, which is also the constructor you use to create instances of the class: ``` r x <- range(start = 1, end = 10) x #> #> @ start: num 1 #> @ end : num 10 ``` ### Properties The data possessed by an object is called its **properties**. Use `@` to get and set properties: ``` r x@start #> [1] 1 x@end <- 20 x #> #> @ start: num 1 #> @ end : num 20 ``` Properties are automatically validated against the type declared in `new_class()` (`double` in this case), and with the class **validator**: ``` r x@end <- "x" #> Error: @end must be , not x@end <- -1 #> Error: object is invalid: #> - @end must be greater than or equal to @start ``` ### Generics and methods Like S3 and S4, S7 uses **functional OOP** where methods belong to **generic** functions, and method calls look like all other function calls: `generic(object, arg2, arg3)`. This style is called functional because from the outside it looks like a regular function call, and internally the components are also functions. Use `new_generic()` to create a new generic: the first argument is the generic name (used in error messages) and the second gives the arguments used for dispatch. The third, and optional argument, supplies the body of the generic. This is only needed if your generic has additional arguments that aren’t used for method dispatch. ``` r inside <- new_generic("inside", "x") ``` Once you have a generic, you can define a method for a specific class with `method<-`: ``` r # Add a method for our class method(inside, range) <- function(x, y) { y >= x@start & y <= x@end } inside(x, c(0, 5, 10, 15)) #> [1] FALSE TRUE TRUE TRUE ``` You can use `method<-` to register methods for base types on S7 generics, and S7 classes on S3 or S4 generics. See `vignette("compatibility")` for more details. S7/build/0000755000176200001440000000000014712722347011653 5ustar liggesusersS7/build/vignette.rds0000644000176200001440000000061214712722347014211 0ustar liggesusers‹¥’ÁRÂ0†A‘›‡¼\t†€Áƒã cuÆkhDÛ¤Ódd¸ùÚ^Ä¥$e[nzȶ»2ûeó¿µ !Uâykð[ëChÀêÁj´ö¹?=Ç¡ÍúAÄ´æz¨ï<0IWŠfÄBDÂl‘p³â’§"ÐØ›µ ñ¡ËXñ §”DÕ‹„lÅñÎnÂÓ¥Jc&ž•‹˜-LLCG:9R&Cji­t;Á¤t#ÌšúwÙFÿÞA?Xè¬lÁÝMŸrh HÔ[aðª…\AN…¤ŒÚ[Xñ|~¼@ ¾ 3^›8r½ËCFÚuqÊHœŒ‰]4gTîäƒFÅžtV/Òz{Gä^öƒkXrƒÃ?õ‚{sì[k}cìŸ9;’?|ÿyÞ«B¨X¸ºd1×Vl¸iÍDä,P&OjóéÌþVÜõšSžp™íì‘o7*…¼Ø¨•ªÍÈ5ëÀª~AØívße¢ìy,‘+¶CfØh™ÂyÈ~~2S7/man/0000755000176200001440000000000014712702212011314 5ustar liggesusersS7/man/convert.Rd0000644000176200001440000000641414712423107013273 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convert.R \name{convert} \alias{convert} \title{Convert an object from one type to another} \usage{ convert(from, to, ...) } \arguments{ \item{from}{An S7 object to convert.} \item{to}{An S7 class specification, passed to \code{\link[=as_class]{as_class()}}.} \item{...}{Other arguments passed to custom \code{convert()} methods. For upcasting, these can be used to override existing properties or set new ones.} } \value{ Either \code{from} coerced to class \code{to}, or an error if the coercion is not possible. } \description{ \code{convert(from, to)} is a built-in generic for converting an object from one type to another. It is special in three ways: \itemize{ \item It uses double-dispatch, because conversion depends on both \code{from} and \code{to}. \item It uses non-standard dispatch because \code{to} is a class, not an object. \item It doesn't use inheritance for the \code{to} argument. To understand why, imagine you have written methods to objects of various types to \code{classParent}. If you then create a new \code{classChild} that inherits from \code{classParent}, you can't expect the methods written for \code{classParent} to work because those methods will return \code{classParent} objects, not \code{classChild} objects. } \code{convert()} provides two default implementations: \enumerate{ \item When \code{from} inherits from \code{to}, it strips any properties that \code{from} possesses that \code{to} does not (downcasting). \item When \code{to} is a subclass of \code{from}'s class, it creates a new object of class \code{to}, copying over existing properties from \code{from} and initializing new properties of \code{to} (upcasting). } If you are converting an object solely for the purposes of accessing a method on a superclass, you probably want \code{\link[=super]{super()}} instead. See its docs for more details. \subsection{S3 & S4}{ \code{convert()} plays a similar role to the convention of defining \code{as.foo()} functions/generics in S3, and to \code{as()}/\code{setAs()} in S4. } } \examples{ Foo1 <- new_class("Foo1", properties = list(x = class_integer)) Foo2 <- new_class("Foo2", Foo1, properties = list(y = class_double)) # Downcasting: S7 provides a default implementation for coercing an object # to one of its parent classes: convert(Foo2(x = 1L, y = 2), to = Foo1) # Upcasting: S7 also provides a default implementation for coercing an object # to one of its child classes: convert(Foo1(x = 1L), to = Foo2) convert(Foo1(x = 1L), to = Foo2, y = 2.5) # Set new property convert(Foo1(x = 1L), to = Foo2, x = 2L, y = 2.5) # Override existing and set new # For all other cases, you'll need to provide your own. try(convert(Foo1(x = 1L), to = class_integer)) method(convert, list(Foo1, class_integer)) <- function(from, to) { from@x } convert(Foo1(x = 1L), to = class_integer) # Note that conversion does not respect inheritance so if we define a # convert method for integer to foo1 method(convert, list(class_integer, Foo1)) <- function(from, to) { Foo1(x = from) } convert(1L, to = Foo1) # Converting to Foo2 will still error try(convert(1L, to = Foo2)) # This is probably not surprising because foo2 also needs some value # for `@y`, but it definitely makes dispatch for convert() special } S7/man/new_union.Rd0000644000176200001440000000330114453045473013614 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/union.R \name{new_union} \alias{new_union} \title{Define a class union} \usage{ new_union(...) } \arguments{ \item{...}{The classes to include in the union. See \code{\link[=as_class]{as_class()}} for details.} } \value{ An S7 union, i.e. a list with class \code{S7_union}. } \description{ A class union represents a list of possible classes. You can create it with \code{new_union(a, b, c)} or \code{a | b | c}. Unions can be used in two places: \itemize{ \item To allow a property to be one of a set of classes, \code{new_property(class_integer | Range)}. The default \code{default} value for the property will be the constructor of the first object in the union. This means if you want to create an "optional" property (i.e. one that can be \code{NULL} or of a specified type), you'll need to write (e.g.) \code{NULL | class_integer}. \item As a convenient short-hand to define methods for multiple classes. \code{method(foo, X | Y) <- f} is short-hand for \verb{method(foo, X) <- f; method(foo, Y) <- foo} } S7 includes built-in unions for "numeric" (integer and double vectors), "atomic" (logical, numeric, complex, character, and raw vectors) and "vector" (atomic vectors, lists, and expressions). } \examples{ logical_or_character <- new_union(class_logical, class_character) logical_or_character # or with shortcut syntax logical_or_character <- class_logical | class_character Foo <- new_class("Foo", properties = list(x = logical_or_character)) Foo(x = TRUE) Foo(x = letters[1:5]) try(Foo(1:3)) bar <- new_generic("bar", "x") # Use built-in union method(bar, class_atomic) <- function(x) "Hi!" bar bar(TRUE) bar(letters) try(bar(NULL)) } S7/man/base_classes.Rd0000644000176200001440000000356414703771245014256 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/base.R \docType{data} \name{base_classes} \alias{base_classes} \alias{class_logical} \alias{class_integer} \alias{class_double} \alias{class_complex} \alias{class_character} \alias{class_raw} \alias{class_list} \alias{class_expression} \alias{class_name} \alias{class_call} \alias{class_function} \alias{class_environment} \alias{class_numeric} \alias{class_atomic} \alias{class_vector} \alias{class_language} \title{S7 wrappers for base types} \usage{ class_logical class_integer class_double class_complex class_character class_raw class_list class_expression class_name class_call class_function class_environment class_numeric class_atomic class_vector class_language } \value{ S7 classes wrapping around common base types and S3 classes. } \description{ The following S7 classes represent base types allowing them to be used within S7: \itemize{ \item \code{class_logical} \item \code{class_integer} \item \code{class_double} \item \code{class_complex} \item \code{class_character} \item \code{class_raw} \item \code{class_list} \item \code{class_expression} \item \code{class_name} \item \code{class_call} \item \code{class_function} \item \code{class_environment} (can only be used for properties) } We also include three union types to model numerics, atomics, and vectors respectively: \itemize{ \item \code{class_numeric} is a union of \code{class_integer} and \code{class_double}. \item \code{class_atomic} is a union of \code{class_logical}, \code{class_numeric}, \code{class_complex}, \code{class_character}, and \code{class_raw}. \item \code{class_vector} is a union of \code{class_atomic}, \code{class_list}, and \code{class_expression}. \item \code{class_language} is a union of \code{class_name} and \code{class_call}. } } \examples{ class_integer class_numeric class_factor } \keyword{datasets} S7/man/methods_register.Rd0000644000176200001440000000137214512327350015161 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/external-generic.R \name{methods_register} \alias{methods_register} \title{Register methods in a package} \usage{ methods_register() } \value{ Nothing; called for its side-effects. } \description{ When using S7 in a package you should always call \code{methods_register()} when your package is loaded. This ensures that methods are registered as needed when you implement methods for generics (S3, S4, and S7) in other packages. (This is not strictly necessary if you only register methods for generics in your package, but it's better to include it and not need it than forget to include it and hit weird errors.) } \examples{ .onLoad <- function(...) { S7::methods_register() } } S7/man/method_explain.Rd0000644000176200001440000000275414712423107014616 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/method-introspect.R \name{method_explain} \alias{method_explain} \title{Explain method dispatch} \usage{ method_explain(generic, class = NULL, object = NULL) } \arguments{ \item{generic}{A generic function, i.e. an \link[=new_generic]{S7 generic}, an \link[=new_external_generic]{external generic}, an \link[=UseMethod]{S3 generic}, or an \link[methods:setGeneric]{S4 generic}.} \item{class, object}{Perform introspection either with a \code{class} (processed with \code{\link[=as_class]{as_class()}}) or a concrete \code{object}. If \code{generic} uses multiple dispatch then both \code{object} and \code{class} must be a list of classes/objects.} } \value{ Nothing; this function is called for it's side effects. } \description{ \code{method_explain()} shows all possible methods that a call to a generic might use, which ones exist, and which one will actually be called. Note that method dispatch uses a string representation of each class in the class hierarchy. Each class system uses a slightly different convention to avoid ambiguity. \itemize{ \item S7: \code{pkg::class} or \code{class} \item S4: \code{S4/pkg::class} or \code{S4/class} \item S3: \code{class} } } \examples{ Foo1 <- new_class("Foo1") Foo2 <- new_class("Foo2", Foo1) add <- new_generic("add", c("x", "y")) method(add, list(Foo2, Foo1)) <- function(x, y) c(2, 1) method(add, list(Foo1, Foo1)) <- function(x, y) c(1, 1) method_explain(add, list(Foo2, Foo2)) } S7/man/S7_object.Rd0000644000176200001440000000047614453045720013437 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/zzz.R \name{S7_object} \alias{S7_object} \title{Base S7 class} \usage{ S7_object() } \value{ The base S7 object. } \description{ The base class from which all S7 classes eventually inherit from. } \examples{ S7_object } \keyword{internal} S7/man/super.Rd0000644000176200001440000000721414712423107012750 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/super.R \name{super} \alias{super} \title{Force method dispatch to use a superclass} \usage{ super(from, to) } \arguments{ \item{from}{An S7 object to cast.} \item{to}{An S7 class specification, passed to \code{\link[=as_class]{as_class()}}. Must be a superclass of \code{object}.} } \value{ An \code{S7_super} object which should always be passed immediately to a generic. It has no other special behavior. } \description{ \code{super(from, to)} causes the dispatch for the next generic to use the method for the superclass \code{to} instead of the actual class of \code{from}. It's needed when you want to implement a method in terms of the implementation of its superclass. \subsection{S3 & S4}{ \code{super()} performs a similar role to \code{\link[=NextMethod]{NextMethod()}} in S3 or \code{\link[methods:NextMethod]{methods::callNextMethod()}} in S4, but is much more explicit: \itemize{ \item The super class that \code{super()} will use is known when write \code{super()} (i.e. statically) as opposed to when the generic is called (i.e. dynamically). \item All arguments to the generic are explicit; they are not automatically passed along. } This makes \code{super()} more verbose, but substantially easier to understand and reason about. } \subsection{\code{super()} in S3 generics}{ Note that you can't use \code{super()} in methods for an S3 generic. For example, imagine that you have made a subclass of "integer": \if{html}{\out{
}}\preformatted{MyInt <- new_class("MyInt", parent = class_integer, package = NULL) }\if{html}{\out{
}} Now you go to write a custom print method: \if{html}{\out{
}}\preformatted{method(print, MyInt) <- function(x, ...) \{ cat("") print(super(x, to = class_integer)) \} MyInt(10L) #> super(, ) }\if{html}{\out{
}} This doesn't work because \code{print()} isn't an S7 generic so doesn't understand how to interpret the special object that \code{super()} produces. While you could resolve this problem with \code{\link[=NextMethod]{NextMethod()}} (because S7 is implemented on top of S3), we instead recommend using \code{\link[=S7_data]{S7_data()}} to extract the underlying base object: \if{html}{\out{
}}\preformatted{method(print, MyInt) <- function(x, ...) \{ cat("") print(S7_data(x)) \} MyInt(10L) #> [1] 10 }\if{html}{\out{
}} } } \examples{ Foo1 <- new_class("Foo1", properties = list(x = class_numeric, y = class_numeric)) Foo2 <- new_class("Foo2", Foo1, properties = list(z = class_numeric)) total <- new_generic("total", "x") method(total, Foo1) <- function(x) x@x + x@y # This won't work because it'll be stuck in an infinite loop: method(total, Foo2) <- function(x) total(x) + x@z # We could write method(total, Foo2) <- function(x) x@x + x@y + x@z # but then we'd need to remember to update it if the implementation # for total() ever changed. # So instead we use `super()` to call the method for the parent class: method(total, Foo2) <- function(x) total(super(x, to = Foo1)) + x@z total(Foo2(1, 2, 3)) # To see the difference between convert() and super() we need a # method that calls another generic bar1 <- new_generic("bar1", "x") method(bar1, Foo1) <- function(x) 1 method(bar1, Foo2) <- function(x) 2 bar2 <- new_generic("bar2", "x") method(bar2, Foo1) <- function(x) c(1, bar1(x)) method(bar2, Foo2) <- function(x) c(2, bar1(x)) obj <- Foo2(1, 2, 3) bar2(obj) # convert() affects every generic: bar2(convert(obj, to = Foo1)) # super() only affects the _next_ call to a generic: bar2(super(obj, to = Foo1)) } S7/man/S7_data.Rd0000644000176200001440000000171614712423107013075 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \name{S7_data} \alias{S7_data} \alias{S7_data<-} \title{Get/set underlying "base" data} \usage{ S7_data(object) S7_data(object, check = TRUE) <- value } \arguments{ \item{object}{An object from a S7 class} \item{check}{If \code{TRUE}, check that \code{value} is of the correct type and run \code{\link[=validate]{validate()}} on the object before returning.} \item{value}{Object used to replace the underlying data.} } \value{ \code{S7_data()} returns the data stored in the base object; \verb{S7_data<-()} is called for its side-effects and returns \code{object} invisibly. } \description{ When an S7 class inherits from an existing base type, it can be useful to work with the underlying object, i.e. the S7 object stripped of class and properties. } \examples{ Text <- new_class("Text", parent = class_character) y <- Text(c(foo = "bar")) y S7_data(y) S7_data(y) <- c("a", "b") y } S7/man/S4_register.Rd0000644000176200001440000000143714712423107014005 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/S4.R \name{S4_register} \alias{S4_register} \title{Register an S7 class with S4} \usage{ S4_register(class, env = parent.frame()) } \arguments{ \item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}.} \item{env}{Expert use only. Environment where S4 class will be registered.} } \value{ Nothing; the function is called for its side-effect. } \description{ If you want to use \link{method<-} to register an method for an S4 generic with an S7 class, you need to call \code{S4_register()} once. } \examples{ methods::setGeneric("S4_generic", function(x) { standardGeneric("S4_generic") }) Foo <- new_class("Foo") S4_register(Foo) method(S4_generic, Foo) <- function(x) "Hello" S4_generic(Foo()) } S7/man/class_any.Rd0000644000176200001440000000074414533115246013572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/special.R \docType{data} \name{class_any} \alias{class_any} \title{Dispatch on any class} \usage{ class_any } \description{ Use \code{class_any} to register a default method that is called when no other methods are matched. } \examples{ foo <- new_generic("foo", "x") method(foo, class_numeric) <- function(x) "number" method(foo, class_any) <- function(x) "fallback" foo(1) foo("x") } \keyword{datasets} S7/man/new_generic.Rd0000644000176200001440000000574214453045473014113 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generic.R, R/method-dispatch.R \name{new_generic} \alias{new_generic} \alias{S7_dispatch} \title{Define a new generic} \usage{ new_generic(name, dispatch_args, fun = NULL) S7_dispatch() } \arguments{ \item{name}{The name of the generic. This should be the same as the object that you assign it to.} \item{dispatch_args}{A character vector giving the names of one or more arguments used to find the method.} \item{fun}{An optional specification of the generic, which must call \code{S7_dispatch()} to dispatch to methods. This is usually generated automatically from the \code{dispatch_args}, but you may want to supply it if you want to add additional required arguments, omit \code{...}, or perform some standardised computation in the generic. The \code{dispatch_args} must be the first arguments to \code{fun}, and, if present, \code{...} must immediately follow them.} } \value{ An S7 generic, i.e. a function with class \code{S7_generic}. } \description{ A generic function uses different implementations (\emph{methods}) depending on the class of one or more arguments (the \emph{signature}). Create a new generic with \code{new_generic()} then use \link{method<-} to add methods to it. Method dispatch is performed by \code{S7_dispatch()}, which must always be included in the body of the generic, but in most cases \code{new_generic()} will generate this for you. Learn more in \code{vignette("generics-methods")} } \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") method(type_of, class_character) <- function(x, ...) "A character vector" method(type_of, new_S3_class("data.frame")) <- function(x, ...) "A data frame" method(type_of, class_function) <- function(x, ...) "A function" type_of(mtcars) type_of(letters) type_of(mean) # If you want to require that methods implement additional arguments, # you can use a custom function: mean2 <- new_generic("mean2", "x", function(x, ..., na.rm = FALSE) { S7_dispatch() }) method(mean2, class_numeric) <- function(x, ..., na.rm = FALSE) { if (na.rm) { x <- x[!is.na(x)] } sum(x) / length(x) } # You'll be warned if you forget the argument: method(mean2, class_character) <- function(x, ...) { stop("Not supported") } } \seealso{ \code{\link[=new_external_generic]{new_external_generic()}} to define a method for a generic in another package without taking a strong dependency on it. } S7/man/validate.Rd0000644000176200001440000000501314453045720013401 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/valid.R \name{validate} \alias{validate} \alias{valid_eventually} \alias{valid_implicitly} \title{Validate an S7 object} \usage{ validate(object, recursive = TRUE, properties = TRUE) valid_eventually(object, fun) valid_implicitly(object, fun) } \arguments{ \item{object}{An S7 object} \item{recursive}{If \code{TRUE}, calls validator of parent classes recursively.} \item{properties}{If \code{TRUE}, the default, checks property types before executing the validator.} \item{fun}{A function to call on the object before validation.} } \value{ Either \code{object} invisibly if valid, otherwise an error. } \description{ \code{validate()} ensures that an S7 object is valid by calling the \code{validator} provided in \code{\link[=new_class]{new_class()}}. This is done automatically when constructing new objects and when modifying properties. \code{valid_eventually()} disables validation, modifies the object, then revalidates. This is useful when a sequence of operations would otherwise lead an object to be temporarily invalid, or when repeated property modification causes a performance bottleneck because the validator is relatively expensive. \code{valid_implicitly()} does the same but does not validate the object at the end. It should only be used rarely, and in performance critical code where you are certain a sequence of operations cannot produce an invalid object. } \examples{ # A range class might validate that the start is less than the end Range <- new_class("Range", properties = list(start = class_double, end = class_double), validator = function(self) { if (self@start >= self@end) "start must be smaller than end" } ) # You can't construct an invalid object: try(Range(1, 1)) # And you can't create an invalid object with @<- r <- Range(1, 2) try(r@end <- 1) # But what if you want to move a range to the right? rightwards <- function(r, x) { r@start <- r@start + x r@end <- r@end + x r } # This function doesn't work because it creates a temporarily invalid state try(rightwards(r, 10)) # This is the perfect use case for valid_eventually(): rightwards <- function(r, x) { valid_eventually(r, function(object) { object@start <- object@start + x object@end <- object@end + x object }) } rightwards(r, 10) # Alternatively, you can set multiple properties at once using props<-, # which validates once at the end rightwards <- function(r, x) { props(r) <- list(start = r@start + x, end = r@end + x) r } rightwards(r, 20) } S7/man/new_S3_class.Rd0000644000176200001440000000751014712423107014134 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/S3.R \name{new_S3_class} \alias{new_S3_class} \title{Declare an S3 class} \usage{ new_S3_class(class, constructor = NULL, validator = NULL) } \arguments{ \item{class}{S3 class vector (i.e. what \code{class()} returns). For method registration, you can abbreviate this to a single string, the S3 class name.} \item{constructor}{An optional constructor that can be used to create objects of the specified class. This is only needed if you wish to have an S7 class inherit from an S3 class or to use the S3 class as a property without a default. It must be specified in the same way as a S7 constructor: the first argument should be \code{.data} (the base type whose attributes will be modified). All arguments to the constructor should have default values so that when the constructor is called with no arguments, it returns returns an "empty", but valid, object.} \item{validator}{An optional validator used by \code{\link[=validate]{validate()}} to check that the S7 object adheres to the constraints of the S3 class. A validator is a single argument function that takes the object to validate and returns \code{NULL} if the object is valid. If the object is invalid, it returns a character vector of problems.} } \value{ An S7 definition of an S3 class, i.e. a list with class \code{S7_S3_class}. } \description{ To use an S3 class with S7, you must explicitly declare it using \code{new_S3_class()} because S3 lacks a formal class definition. (Unless it's an important base class already defined in \link{base_s3_classes}.) } \section{Method dispatch, properties, and unions}{ There are three ways of using S3 with S7 that only require the S3 class vector: \itemize{ \item Registering a S3 method for an S7 generic. \item Restricting an S7 property to an S3 class. \item Using an S3 class in an S7 union. } This is easy, and you can usually include the \code{new_S3_class()} call inline: \if{html}{\out{
}}\preformatted{method(my_generic, new_S3_class("factor")) <- function(x) "A factor" new_class("MyClass", properties = list(types = new_S3_class("factor"))) new_union("character", new_S3_class("factor")) }\if{html}{\out{
}} } \section{Extending an S3 class}{ Creating an S7 class that extends an S3 class requires more work. You'll also need to provide a constructor for the S3 class that follows S7 conventions. This means the first argument to the constructor should be \code{.data}, and it should be followed by one argument for each attribute used by the class. This can be awkward because base S3 classes are usually heavily wrapped for user convenience and no low level constructor is available. For example, the factor class is an integer vector with a character vector of \code{levels}, but there's no base R function that takes an integer vector of values and character vector of levels, verifies that they are consistent, then creates a factor object. You may optionally want to also provide a \code{validator} function which will ensure that \code{\link[=validate]{validate()}} confirms the validity of any S7 classes that build on this class. Unlike an S7 validator, you are responsible for validating the types of the attributes. The following code shows how you might wrap the base Date class. A Date is a numeric vector with class \code{Date} that can be constructed with \code{.Date()}. \if{html}{\out{
}}\preformatted{S3_Date <- new_S3_class("Date", function(.data = integer()) \{ .Date(.data) \}, function(self) \{ if (!is.numeric(self)) \{ "Underlying data must be numeric" \} \} ) }\if{html}{\out{
}} } \examples{ # No checking, just used for dispatch Date <- new_S3_class("Date") my_generic <- new_generic("my_generic", "x") method(my_generic, Date) <- function(x) "This is a date" my_generic(Sys.Date()) } S7/man/class_missing.Rd0000644000176200001440000000132614675323445014462 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/special.R \docType{data} \name{class_missing} \alias{class_missing} \title{Dispatch on a missing argument} \usage{ class_missing } \value{ Sentinel objects used for special types of dispatch. } \description{ Use \code{class_missing} to dispatch when the user has not supplied an argument, i.e. it's missing in the sense of \code{\link[=missing]{missing()}}, not in the sense of \code{\link[=is.na]{is.na()}}. } \examples{ foo <- new_generic("foo", "x") method(foo, class_numeric) <- function(x) "number" method(foo, class_missing) <- function(x) "missing" method(foo, class_any) <- function(x) "fallback" foo(1) foo() foo("") } \keyword{datasets} S7/man/method-set.Rd0000644000176200001440000000512114533115246013661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/method-register.R \name{method<-} \alias{method<-} \title{Register an S7 method for a generic} \usage{ method(generic, signature) <- value } \arguments{ \item{generic}{A generic function, i.e. an \link[=new_generic]{S7 generic}, an \link[=new_external_generic]{external generic}, an \link[=UseMethod]{S3 generic}, or an \link[methods:setGeneric]{S4 generic}.} \item{signature}{A method signature. For S7 generics that use single dispatch, this must be one of the following: \itemize{ \item An S7 class (created by \code{\link[=new_class]{new_class()}}). \item An S7 union (created by \code{\link[=new_union]{new_union()}}). \item An S3 class (created by \code{\link[=new_S3_class]{new_S3_class()}}). \item An S4 class (created by \code{\link[methods:getClass]{methods::getClass()}} or \code{\link[methods:new]{methods::new()}}). \item A base type like \link{class_logical}, \link{class_integer}, or \link{class_numeric}. \item A special type like \link{class_missing} or \link{class_any}. } For S7 generics that use multiple dispatch, this must be a list of any of the above types. For S3 generics, this must be a single S7 class. For S4 generics, this must either be an S7 class, or a list that includes at least one S7 class.} \item{value}{A function that implements the generic specification for the given \code{signature}.} } \value{ The \code{generic}, invisibly. } \description{ A generic defines the interface of a function. Once you have created a generic with \code{\link[=new_generic]{new_generic()}}, you provide implementations for specific signatures by registering methods with \verb{method<-}. The goal is for \verb{method<-} to be the single function you need when working with S7 generics or S7 classes. This means that as well as registering methods for S7 classes on S7 generics, you can also register methods for S7 classes on S3 or S4 generics, and S3 or S4 classes on S7 generics. But this is not a general method registration function: at least one of \code{generic} and \code{signature} needs to be from S7. Note that if you are writing a package, you must call \code{\link[=methods_register]{methods_register()}} in your \code{.onLoad}. This ensures that all methods are dynamically registered when needed. } \examples{ # Create a generic bizarro <- new_generic("bizarro", "x") # Register some methods method(bizarro, class_numeric) <- function(x) rev(x) method(bizarro, new_S3_class("data.frame")) <- function(x) { x[] <- lapply(x, bizarro) rev(x) } # Using a generic calls the methods automatically bizarro(head(mtcars)) } S7/man/new_class.Rd0000644000176200001440000001027314712423107013567 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/class.R \name{new_class} \alias{new_class} \alias{new_object} \title{Define a new S7 class} \usage{ new_class( name, parent = S7_object, package = topNamespaceName(parent.frame()), properties = list(), abstract = FALSE, constructor = NULL, validator = NULL ) new_object(.parent, ...) } \arguments{ \item{name}{The name of the class, as a string. The result of calling \code{new_class()} should always be assigned to a variable with this name, i.e. \code{Foo <- new_class("Foo")}.} \item{parent}{The parent class to inherit behavior from. There are three options: \itemize{ \item An S7 class, like \link{S7_object}. \item An S3 class wrapped by \code{\link[=new_S3_class]{new_S3_class()}}. \item A base type, like \link{class_logical}, \link{class_integer}, etc. }} \item{package}{Package name. This is automatically resolved if the class is defined in a package, and \code{NULL} otherwise. Note, if the class is intended for external use, the constructor should be exported. Learn more in \code{vignette("packages")}.} \item{properties}{A named list specifying the properties (data) that belong to each instance of the class. Each element of the list can either be a type specification (processed by \code{\link[=as_class]{as_class()}}) or a full property specification created \code{\link[=new_property]{new_property()}}.} \item{abstract}{Is this an abstract class? An abstract class can not be instantiated.} \item{constructor}{The constructor function. In most cases, you can rely on the default constructor, which will generate a function with one argument for each property. A custom constructor should call \code{new_object()} to create the S7 object. The first argument, \code{.data}, should be an instance of the parent class (if used). The subsequent arguments are used to set the properties.} \item{validator}{A function taking a single argument, \code{self}, the object to validate. The job of a validator is to determine whether the object is valid, i.e. if the current property values form an allowed combination. The types of the properties are always automatically validated so the job of the validator is to verify that the \emph{values} of individual properties are ok (i.e. maybe a property should have length 1, or should always be positive), or that the \emph{combination} of values of multiple properties is ok. It is called after construction and whenever any property is set. The validator should return \code{NULL} if the object is valid. If not, it should return a character vector where each element describes a single problem, using \verb{@prop_name} to describe where the problem lies. See \code{validate()} for more details, examples, and how to temporarily suppress validation when needed.} \item{.parent, ...}{Parent object and named properties used to construct the object.} } \value{ A object constructor, a function that can be used to create objects of the given class. } \description{ A class specifies the properties (data) that each of its objects will possess. The class, and its parent, determines which method will be used when an object is passed to a generic. Learn more in \code{vignette("classes-objects")} } \examples{ # Create an class that represents a range using a numeric start and end Range <- new_class("Range", properties = list( start = class_numeric, end = class_numeric ) ) r <- Range(start = 10, end = 20) r # get and set properties with @ r@start r@end <- 40 r@end # S7 automatically ensures that properties are of the declared types: try(Range(start = "hello", end = 20)) # But we might also want to use a validator to ensure that start and end # are length 1, and that start is < end Range <- new_class("Range", properties = list( start = class_numeric, end = class_numeric ), validator = function(self) { if (length(self@start) != 1) { "@start must be a single number" } else if (length(self@end) != 1) { "@end must be a single number" } else if (self@end < self@start) { "@end must be great than or equal to @start" } } ) try(Range(start = c(10, 15), end = 20)) try(Range(start = 20, end = 10)) r <- Range(start = 10, end = 20) try(r@start <- 25) } S7/man/props.Rd0000644000176200001440000000242114712423107012750 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/property.R \name{props} \alias{props} \alias{props<-} \alias{set_props} \title{Get/set multiple properties} \usage{ props(object, names = prop_names(object)) props(object) <- value set_props(object, ...) } \arguments{ \item{object}{An object from a S7 class} \item{names}{A character vector of property names to retrieve. Default is all properties.} \item{value}{A named list of values. The object is checked for validity only after all replacements are performed.} \item{...}{Name-value pairs given property to modify and new value.} } \value{ A named list of property values. } \description{ \itemize{ \item \code{props(x)} returns all properties. \item \code{props(x) <- list(name1 = val1, name2 = val2)} modifies an existing object by setting multiple properties simultaneously. \item \code{set_props(x, name1 = val1, name2 = val2)} creates a copy of an existing object with new values for the specified properties. } } \examples{ Horse <- new_class("Horse", properties = list( name = class_character, colour = class_character, height = class_numeric )) lexington <- Horse(colour = "bay", height = 15, name = "Lex") props(lexington) props(lexington) <- list(height = 14, name = "Lexington") lexington } S7/man/new_external_generic.Rd0000644000176200001440000000310114712423107015770 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/external-generic.R \name{new_external_generic} \alias{new_external_generic} \title{Generics in other packages} \usage{ new_external_generic(package, name, dispatch_args, version = NULL) } \arguments{ \item{package}{Package the generic is defined in.} \item{name}{Name of generic, as a string.} \item{dispatch_args}{Character vector giving arguments used for dispatch.} \item{version}{An optional version the package must meet for the method to be registered.} } \value{ An S7 external generic, i.e. a list with class \code{S7_external_generic}. } \description{ You need an explicit external generic when you want to provide methods for a generic (S3, S4, or S7) that is defined in another package, and you don't want to take a hard dependency on that package. The easiest way to provide methods for generics in other packages is import the generic into your \code{NAMESPACE}. This, however, creates a hard dependency, and sometimes you want a soft dependency, only registering the method if the package is already installed. \code{new_external_generic()} allows you to provide the minimal needed information about a generic so that methods can be registered at run time, as needed, using \code{\link[=methods_register]{methods_register()}}. Note that in tests, you'll need to explicitly call the generic from the external package with \code{pkg::generic()}. } \examples{ MyClass <- new_class("MyClass") your_generic <- new_external_generic("stats", "median", "x") method(your_generic, MyClass) <- function(x) "Hi!" } S7/man/S7_class.Rd0000644000176200001440000000057414712423107013272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/class.R \name{S7_class} \alias{S7_class} \title{Retrieve the S7 class of an object} \usage{ S7_class(object) } \arguments{ \item{object}{The S7 object} } \value{ An \link[=new_class]{S7 class}. } \description{ Given an S7 object, find it's class. } \examples{ Foo <- new_class("Foo") S7_class(Foo()) } S7/man/new_property.Rd0000644000176200001440000000656014712423107014352 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/property.R \name{new_property} \alias{new_property} \title{Define a new property} \usage{ new_property( class = class_any, getter = NULL, setter = NULL, validator = NULL, default = NULL, name = NULL ) } \arguments{ \item{class}{Class that the property must be an instance of. See \code{\link[=as_class]{as_class()}} for details.} \item{getter}{An optional function used to get the value. The function should take \code{self} as its sole argument and return the value. If you supply a \code{getter}, you are responsible for ensuring that it returns an object of the correct \code{class}; it will not be validated automatically. If a property has a getter but doesn't have a setter, it is read only.} \item{setter}{An optional function used to set the value. The function should take \code{self} and \code{value} and return a modified object.} \item{validator}{A function taking a single argument, \code{value}, the value to validate. The job of a validator is to determine whether the property value is valid. It should return \code{NULL} if the object is valid, or if it's not valid, a single string describing the problem. The message should not include the name of the property as this will be automatically appended to the beginning of the message. The validator will be called after the \code{class} has been verified, so your code can assume that \code{value} has known type.} \item{default}{When an object is created and the property is not supplied, what should it default to? If \code{NULL}, it defaults to the "empty" instance of \code{class}. This can also be a quoted call, which then becomes a standard function promise in the default constructor, evaluated at the time the object is constructed.} \item{name}{Property name, primarily used for error messages. Generally don't need to set this here, as it's more convenient to supply as a the element name when defining a list of properties. If both \code{name} and a list-name are supplied, the list-name will be used.} } \value{ An S7 property, i.e. a list with class \code{S7_property}. } \description{ A property defines a named component of an object. Properties are typically used to store (meta) data about an object, and are often limited to a data of a specific \code{class}. By specifying a \code{getter} and/or \code{setter}, you can make the property "dynamic" so that it's computed when accessed or has some non-standard behaviour when modified. Dynamic properties are not included as an argument to the default class constructor. See the "Properties: Common Patterns" section in \code{vignette("class-objects")} for more examples. } \examples{ # Simple properties store data inside an object Pizza <- new_class("Pizza", properties = list( slices = new_property(class_numeric, default = 10) )) my_pizza <- Pizza(slices = 6) my_pizza@slices my_pizza@slices <- 5 my_pizza@slices your_pizza <- Pizza() your_pizza@slices # Dynamic properties can compute on demand Clock <- new_class("Clock", properties = list( now = new_property(getter = function(self) Sys.time()) )) my_clock <- Clock() my_clock@now; Sys.sleep(1) my_clock@now # This property is read only, because there is a 'getter' but not a 'setter' try(my_clock@now <- 10) # Because the property is dynamic, it is not included as an # argument to the default constructor try(Clock(now = 10)) args(Clock) } S7/man/base_s3_classes.Rd0000644000176200001440000000151414712243624014647 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/S3.R \docType{data} \name{base_s3_classes} \alias{base_s3_classes} \alias{class_factor} \alias{class_Date} \alias{class_POSIXct} \alias{class_POSIXlt} \alias{class_POSIXt} \alias{class_data.frame} \alias{class_formula} \title{S7 wrappers for key S3 classes} \usage{ class_factor class_Date class_POSIXct class_POSIXlt class_POSIXt class_data.frame class_formula } \description{ S7 bundles \link[=new_S3_class]{S3 definitions} for key S3 classes provided by the base packages: \itemize{ \item \code{class_data.frame} for data frames. \item \code{class_Date} for dates. \item \code{class_factor} for factors. \item \code{class_POSIXct}, \code{class_POSIXlt} and \code{class_POSIXt} for date-times. \item \code{class_formula} for formulas. } } \keyword{datasets} S7/man/as_class.Rd0000644000176200001440000000234214533115246013402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/class-spec.R \name{as_class} \alias{as_class} \title{Standard class specifications} \usage{ as_class(x, arg = deparse(substitute(x))) } \arguments{ \item{x}{A class specification. One of the following: \itemize{ \item An S7 class (created by \code{\link[=new_class]{new_class()}}). \item An S7 union (created by \code{\link[=new_union]{new_union()}}). \item An S3 class (created by \code{\link[=new_S3_class]{new_S3_class()}}). \item An S4 class (created by \code{\link[methods:getClass]{methods::getClass()}} or \code{\link[methods:new]{methods::new()}}). \item A base class, like \link{class_logical}, \link{class_integer}, or \link{class_double}. \item A "special", either \link{class_missing} or \link{class_any}. }} \item{arg}{Argument name used when generating errors.} } \value{ A standardised class: either \code{NULL}, an S7 class, an S7 union, as \link{new_S3_class}, or a S4 class. } \description{ This is used as the interface between S7 and R's other OO systems, allowing you to use S7 classes and methods with base types, informal S3 classes, and formal S4 classes. } \examples{ as_class(class_logical) as_class(new_S3_class("factor")) } \keyword{internal} S7/man/method.Rd0000644000176200001440000000352614533115246013077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/method-introspect.R \name{method} \alias{method} \title{Find a method for an S7 generic} \usage{ method(generic, class = NULL, object = NULL) } \arguments{ \item{generic}{A generic function, i.e. an \link[=new_generic]{S7 generic}, an \link[=new_external_generic]{external generic}, an \link[=UseMethod]{S3 generic}, or an \link[methods:setGeneric]{S4 generic}.} \item{class, object}{Perform introspection either with a \code{class} (processed with \code{\link[=as_class]{as_class()}}) or a concrete \code{object}. If \code{generic} uses multiple dispatch then both \code{object} and \code{class} must be a list of classes/objects.} } \value{ Either a function with class \code{S7_method} or an error if no matching method is found. } \description{ \code{method()} takes a generic and class signature and performs method dispatch to find the corresponding method implementation. This is rarely needed because you'll usually rely on the the generic to do dispatch for you (via \code{\link[=S7_dispatch]{S7_dispatch()}}). However, this introspection is useful if you want to see the implementation of a specific method. } \examples{ # Create a generic and register some methods bizarro <- new_generic("bizarro", "x") method(bizarro, class_numeric) <- function(x) rev(x) method(bizarro, class_factor) <- function(x) { levels(x) <- rev(levels(x)) x } # Printing the generic shows the registered method bizarro # And you can use method() to inspect specific implementations method(bizarro, class = class_integer) method(bizarro, object = 1) method(bizarro, class = class_factor) # errors if method not found try(method(bizarro, class = class_data.frame)) try(method(bizarro, object = "x")) } \seealso{ \code{\link[=method_explain]{method_explain()}} to explain why a specific method was picked. } S7/man/prop_names.Rd0000644000176200001440000000152414712423107013753 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/property.R \name{prop_names} \alias{prop_names} \alias{prop_exists} \title{Property introspection} \usage{ prop_names(object) prop_exists(object, name) } \arguments{ \item{object}{An object from a S7 class} \item{name}{The name of the parameter as a character. Partial matching is not performed.} } \value{ \code{prop_names()} returns a character vector; \code{prop_exists()} returns a single \code{TRUE} or \code{FALSE}. } \description{ \itemize{ \item \code{prop_names(x)} returns the names of the properties \item \code{prop_exists(x, "prop")} returns \code{TRUE} iif \code{x} has property \code{prop}. } } \examples{ Foo <- new_class("Foo", properties = list(a = class_character, b = class_integer)) f <- Foo() prop_names(f) prop_exists(f, "a") prop_exists(f, "c") } S7/man/S7_inherits.Rd0000644000176200001440000000237314712702212014006 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/inherits.R \name{S7_inherits} \alias{S7_inherits} \alias{check_is_S7} \title{Does this object inherit from an S7 class?} \usage{ S7_inherits(x, class = NULL) check_is_S7(x, class = NULL, arg = deparse(substitute(x))) } \arguments{ \item{x}{An object} \item{class}{An S7 class or \code{NULL}. If \code{NULL}, tests whether \code{x} is an S7 object without testing for a specific class.} \item{arg}{Argument name used in error message.} } \value{ \itemize{ \item \code{S7_inherits()} returns a single \code{TRUE} or \code{FALSE}. \item \code{check_is_S7()} returns nothing; it's called for its side-effects. } } \description{ \itemize{ \item \code{S7_inherits()} returns \code{TRUE} or \code{FALSE}. \item \code{check_is_S7()} throws an error if \code{x} isn't the specified \code{class}. } } \note{ Starting with \R 4.3.0, \code{base::inherits()} can accept an S7 class as the second argument, supporting usage like \code{inherits(x, Foo)}. } \examples{ Foo1 <- new_class("Foo1") Foo2 <- new_class("Foo2") S7_inherits(Foo1(), Foo1) check_is_S7(Foo1()) check_is_S7(Foo1(), Foo1) S7_inherits(Foo1(), Foo2) try(check_is_S7(Foo1(), Foo2)) if (getRversion() >= "4.3.0") inherits(Foo1(), Foo1) } S7/man/prop.Rd0000644000176200001440000000264414712423107012574 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compatibility.R, R/property.R \name{prop} \alias{prop} \alias{@} \alias{prop<-} \alias{@.S7_object} \title{Get/set a property} \usage{ prop(object, name) prop(object, name, check = TRUE) <- value object@name } \arguments{ \item{object}{An object from a S7 class} \item{name}{The name of the parameter as a character. Partial matching is not performed.} \item{check}{If \code{TRUE}, check that \code{value} is of the correct type and run \code{\link[=validate]{validate()}} on the object before returning.} \item{value}{A new value for the property. The object is automatically checked for validity after the replacement is done.} } \value{ \code{prop()} and \code{@} return the value of the property. \verb{prop<-()} and \verb{@<-} are called for their side-effects and return the modified object, invisibly. } \description{ \itemize{ \item \code{prop(x, "name")} / \code{prop@name} get the value of the a property, erroring if it the property doesn't exist. \item \code{prop(x, "name") <- value} / \code{prop@name <- value} set the value of a property. } } \examples{ Horse <- new_class("Horse", properties = list( name = class_character, colour = class_character, height = class_numeric )) lexington <- Horse(colour = "bay", height = 15, name = "Lex") lexington@colour prop(lexington, "colour") lexington@height <- 14 prop(lexington, "height") <- 15 } S7/DESCRIPTION0000644000176200001440000000435314713133572012264 0ustar liggesusersPackage: S7 Title: An Object Oriented System Meant to Become a Successor to S3 and S4 Version: 0.2.0 Authors@R: c( person("Object-Oriented Programming Working Group", role = "cph"), person("Davis", "Vaughan", role = "aut"), person("Jim", "Hester", role = "aut", comment = c(ORCID = "0000-0002-2739-7082")), person("Tomasz", "Kalinowski", role = "aut"), person("Will", "Landau", role = "aut"), person("Michael", "Lawrence", role = "aut"), person("Martin", "Maechler", role = "aut", comment = c(ORCID = "0000-0002-8685-9910")), person("Luke", "Tierney", role = "aut"), person("Hadley", "Wickham", , "hadley@posit.co", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-4757-117X")) ) Description: A new object oriented programming system designed to be a successor to S3 and S4. It includes formal class, generic, and method specification, and a limited form of multiple dispatch. It has been designed and implemented collaboratively by the R Consortium Object-Oriented Programming Working Group, which includes representatives from R-Core, 'Bioconductor', 'Posit'/'tidyverse', and the wider R community. License: MIT + file LICENSE URL: https://rconsortium.github.io/S7/, https://github.com/RConsortium/S7 BugReports: https://github.com/RConsortium/S7/issues Depends: R (>= 3.5.0) Imports: utils Suggests: bench, callr, covr, knitr, methods, rmarkdown, testthat (>= 3.2.0), tibble VignetteBuilder: knitr Config/build/compilation-database: true Config/Needs/website: sloop Config/testthat/edition: 3 Config/testthat/parallel: TRUE Config/testthat/start-first: external-generic Encoding: UTF-8 RoxygenNote: 7.3.2 NeedsCompilation: yes Packaged: 2024-11-06 17:18:31 UTC; hadleywickham Author: Object-Oriented Programming Working Group [cph], Davis Vaughan [aut], Jim Hester [aut] (), Tomasz Kalinowski [aut], Will Landau [aut], Michael Lawrence [aut], Martin Maechler [aut] (), Luke Tierney [aut], Hadley Wickham [aut, cre] () Maintainer: Hadley Wickham Repository: CRAN Date/Publication: 2024-11-07 12:50:02 UTC