diff --git a/R/aaa.R b/R/aaa.R index 2d872fa5..941b5f00 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -26,10 +26,10 @@ new_function <- function(args = NULL, topNamespaceName <- function(env = parent.frame()) { env <- topenv(env) if (!isNamespace(env)) { - return() + return() # print visible } - getNamespaceName(env) + as.character(getNamespaceName(env)) # unname } is_string <- function(x) { diff --git a/R/base.R b/R/base.R index d749a8d6..38b95a8b 100644 --- a/R/base.R +++ b/R/base.R @@ -44,7 +44,7 @@ base_default <- function(type) { name = quote(quote(x)), call = quote(quote({})), - `function` = quote(function() {}), + `function` = quote(function() NULL), environment = quote(new.env(parent = emptyenv())) )} diff --git a/R/class-spec.R b/R/class-spec.R index 65579a45..ba8885ce 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -81,27 +81,49 @@ class_friendly <- function(x) { } class_construct <- function(.x, ...) { - eval(class_construct_expr(.x, ...)) + class_constructor(.x)(...) } -class_construct_expr <- function(.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.) - ## early return if not safe to unwrap - # can't unwrap if we're passing on ... - if(...length()) { - return(as.call(list(f, ...))) - } - # 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, ...))) + if (!identical(fe, baseenv())) { + return(as.call(list(f))) } # special case for `class_missing` @@ -111,8 +133,8 @@ class_construct_expr <- function(.x, ...) { # `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, ...))) + if ("new_object" %in% all.names(fb)) { + return(as.call(list(f))) } # maybe unwrap body if it is a single expression wrapped in `{` @@ -133,7 +155,7 @@ class_construct_expr <- function(.x, ...) { } #else, return a call to the constructor - as.call(list(f, ...)) + as.call(list(f)) } class_constructor <- function(.x) { diff --git a/R/class.R b/R/class.R index c12593d6..f7d71135 100644 --- a/R/class.R +++ b/R/class.R @@ -16,14 +16,11 @@ #' * 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. It is good practice to set the package -#' name when exporting an S7 class from a package because it prevents -#' clashes if two packages happen to export a class with the same -#' name. +#' @param package Package name. This is automatically resolved if the class is +#' defined in a package, and `NULL` otherwise. #' -#' Setting `package` implies that the class is available for external use, -#' so should be accompanied by exporting the constructor. Learn more -#' in `vignette("packages")`. +#' 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 @@ -134,7 +131,9 @@ new_class <- function( all_props[names(new_props)] <- new_props if (is.null(constructor)) { - constructor <- new_constructor(parent, all_props) + constructor <- new_constructor(parent, all_props, + envir = parent.frame(), + package = package) } object <- constructor diff --git a/R/constructor.R b/R/constructor.R index 63df1e78..05c901e1 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -1,18 +1,26 @@ -new_constructor <- function(parent, properties) { +new_constructor <- function(parent, properties, + envir = asNamespace("S7"), package = NULL) { properties <- as_properties(properties) - arg_info <- constructor_args(parent, 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_call("new_object", c(list(quote(S7_object())), self_args)) + new_object_call )), - env = asNamespace("S7") + env = envir )) } @@ -42,15 +50,19 @@ new_constructor <- function(parent, properties) { 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("new_object", c(parent_call, self_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 = asNamespace("S7")) + env <- new.env(parent = envir) env[[parent_name]] <- parent_fun new_function(args, body, env) } -constructor_args <- function(parent, properties = list()) { +constructor_args <- function(parent, properties = list(), + envir = asNamespace("S7"), package = NULL) { parent_args <- formals(class_constructor(parent)) # Remove read-only properties @@ -66,7 +78,7 @@ constructor_args <- function(parent, properties = list()) { self_args <- as.pairlist(lapply( setNames(, self_arg_nms), - function(name) prop_default(properties[[name]])) + function(name) prop_default(properties[[name]], envir, package)) ) list(parent = parent_args, @@ -81,8 +93,14 @@ 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) { - as.call(c(list(as.name(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) { @@ -91,3 +109,14 @@ as_names <- function(x, named = FALSE) { } 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) +} diff --git a/R/property.R b/R/property.R index 1973d421..e2cf4917 100644 --- a/R/property.R +++ b/R/property.R @@ -155,8 +155,8 @@ str.S7_property <- function(object, ..., nest.lev = 0) { print(object, ..., nest.lev = nest.lev) } -prop_default <- function(prop) { - prop$default %||% class_construct_expr(prop$class) +prop_default <- function(prop, envir, package) { + prop$default %||% class_construct_expr(prop$class, envir, package) } #' Get/set a property diff --git a/man/new_class.Rd b/man/new_class.Rd index 60ca3932..43a62718 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -30,14 +30,11 @@ There are three options: \item A base type, like \link{class_logical}, \link{class_integer}, etc. }} -\item{package}{Package name. It is good practice to set the package -name when exporting an S7 class from a package because it prevents -clashes if two packages happen to export a class with the same -name. - -Setting \code{package} implies that the class is available for external use, -so should be accompanied by exporting the constructor. Learn more -in \code{vignette("packages")}.} +\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 diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 72fc4101..57ef9ed1 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -112,7 +112,7 @@ foo <- new_class("foo", abstract = TRUE) foo() Condition - Error in `new_object()`: + Error in `S7::new_object()`: ! Can't construct an object from abstract class # abstract classes: can't inherit from concrete class diff --git a/tests/testthat/_snaps/external-generic.md b/tests/testthat/_snaps/external-generic.md index 0b14fcff..a0c56dc2 100644 --- a/tests/testthat/_snaps/external-generic.md +++ b/tests/testthat/_snaps/external-generic.md @@ -5,3 +5,41 @@ 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 + diff --git a/tests/testthat/t0/NAMESPACE b/tests/testthat/t0/NAMESPACE index 5647257c..d460b7b7 100644 --- a/tests/testthat/t0/NAMESPACE +++ b/tests/testthat/t0/NAMESPACE @@ -1,4 +1,5 @@ # Generated by roxygen2: do not edit by hand +export("An S7 Class") export(an_s3_generic) export(an_s7_generic) diff --git a/tests/testthat/t0/R/t0.R b/tests/testthat/t0/R/t0.R index cf5b6843..bfba20a6 100644 --- a/tests/testthat/t0/R/t0.R +++ b/tests/testthat/t0/R/t0.R @@ -3,3 +3,6 @@ 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") diff --git a/tests/testthat/t2/NAMESPACE b/tests/testthat/t2/NAMESPACE index b5d51e48..0fb0c4c0 100644 --- a/tests/testthat/t2/NAMESPACE +++ b/tests/testthat/t2/NAMESPACE @@ -1,5 +1,7 @@ # 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) diff --git a/tests/testthat/t2/R/t2.R b/tests/testthat/t2/R/t2.R index a98bd7b7..8834b299 100644 --- a/tests/testthat/t2/R/t2.R +++ b/tests/testthat/t2/R/t2.R @@ -10,6 +10,17 @@ S7::method(an_s7_generic, an_s7_class) <- function(x) "foo" 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" @@ -17,6 +28,7 @@ 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() } diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index ba22fcfd..684826c1 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -232,16 +232,19 @@ test_that("c(, ...) gives error", { }) test_that("can round trip to disk and back", { - foo1 <- new_class("foo1", properties = list(y = class_integer)) - foo2 <- new_class("foo2", properties = list(x = foo1)) - - f <- foo2(x = foo1(y = 1L)) + 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(f2, f) + expect_equal(f, f2) + rm(foo1, foo2, f, envir = globalenv()) }) diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R index 02152dc3..323f14b2 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -160,8 +160,6 @@ test_that("can create constructors with missing or lazy defaults", { "Can\'t set read-only property Person@birthdate") }) - - test_that("Dynamic settable properties are included in constructor", { Foo <- new_class( name = "Foo", package = NULL, diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index fb9ce61f..090fc998 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -86,6 +86,39 @@ test_that("new_method works with both hard and soft dependencies", { 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)