Don't inline classes in constructor if possible (RConsortium#481)

* unname `topNamespaceName()` name

* try to use `pkg::cls()` call as constructor default if possible

* add test

* change class constructor parent environment to `new_class()` calling env

* fix non-syntatic class names

* use pkgname instead of env when deciding to not inline constructor calls

* update surrounding code

* Add snapshot test

* Add comment

* update `new_class`: `@param package` doc.

* update snapshot test

* test external classes with actual packages

* use non-syntatic class names in tests

Author: t-kalinowski

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) {

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()))
 )}
 

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) {

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

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)
+}

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

man/new_class.Rd

@@ -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 <foo>
 
 # abstract classes: can't inherit from concrete class

tests/testthat/_snaps/class.md

@@ -5,3 +5,41 @@
     Output
       <S7_external_generic> 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
+

tests/testthat/_snaps/external-generic.md

@@ -1,4 +1,5 @@
 # Generated by roxygen2: do not edit by hand
 
+export("An S7 Class")
 export(an_s3_generic)
 export(an_s7_generic)

tests/testthat/t0/NAMESPACE

@@ -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")

tests/testthat/t0/R/t0.R

@@ -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)

tests/testthat/t2/NAMESPACE

@@ -10,13 +10,25 @@ 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"
 
 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()
 }

tests/testthat/t2/R/t2.R

@@ -232,16 +232,19 @@ test_that("c(<S7_class>, ...) 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())
 })
 
 

tests/testthat/test-class.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,