Automatically detect package name in new_class(package=) (#459)

t-kalinowski · hadley · web-flow · commit b5cf389d7c6d · 2024-10-16T16:10:08.000-04:00
* add `topNamespaceName()`

* fixes to prevent `S7::` class prefix in package code

* fixes to prevent `S7::` class prefix in tests

* add NEWS

* use explicit `package=NULL` in snapshot tests

---------

Co-authored-by: Hadley Wickham &lt;h.wickham@gmail.com&gt;
diff --git a/NEWS.md b/NEWS.md
@@ -1,13 +1,16 @@
 # S7 (development version)
 
+* `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).
 
 * 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_matrix`, `class_array`,
-    `class_formula`, `class_call`, `class_language`, `class_name`
+    `class_POSIXlt`, `class_POSIXt`, `class_formula`, 
+    `class_call`, `class_language`, `class_name`
 
 * Fixed S3 methods registration across packages (#422).
 
diff --git a/R/aaa.R b/R/aaa.R
@@ -22,6 +22,13 @@ new_function <- function(args = NULL,
   x
 }
 
+
+topNamespaceName <- function(env = parent.frame()) {
+  env <- topenv(env)
+  if (isNamespace(env))
+    getNamespaceName(env)
+}
+
 is_string <- function(x) {
   identical(class(x), "character") && length(x) == 1L && !is.na(x) && x != ""
 }
diff --git a/R/class.R b/R/class.R
@@ -100,7 +100,7 @@
 new_class <- function(
     name,
     parent = S7_object,
-    package = NULL,
+    package = topNamespaceName(parent.frame()),
     properties = list(),
     abstract = FALSE,
     constructor = NULL,
diff --git a/R/method-register.R b/R/method-register.R
@@ -107,7 +107,6 @@ register_S3_method <- function(generic, signature, method, envir = parent.frame(
   }
 
   class <- S7_class_name(signature[[1]])
-  # dbg(generic$name, class, method, envir)
   registerS3method(generic$name, class, method, envir)
 }
 
diff --git a/R/super.R b/R/super.R
@@ -26,7 +26,7 @@
 #' For example, imagine that you have made a subclass of "integer":
 #'
 #' ```{r}
-#' myint <- new_class("myint", parent = class_integer)
+#' myint <- new_class("myint", parent = class_integer, package = NULL)
 #' ```
 #'
 #' Now you go to write a custom print method:
diff --git a/R/zzz.R b/R/zzz.R
@@ -10,6 +10,7 @@
 #' S7_object
 S7_object <- new_class(
   name = "S7_object",
+  package = NULL,
   parent = NULL,
   constructor = function() {
     .Call(S7_object_)
@@ -96,6 +97,7 @@ on_load_define_S7_generic <- function() {
   # errors if `@` is not usable.
   S7_generic <<- new_class(
     name = "S7_generic",
+    package = NULL,
     properties = list(
       name = class_character,
       methods = class_environment,
@@ -114,6 +116,7 @@ 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)
   )
diff --git a/man/new_class.Rd b/man/new_class.Rd
diff --git a/man/super.Rd b/man/super.Rd
diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md
@@ -174,7 +174,8 @@
 # S7 object: displays nicely
 
     Code
-      foo <- new_class("foo", properties = list(x = class_double, y = class_double))
+      foo <- new_class("foo", properties = list(x = class_double, y = class_double),
+      package = NULL)
       foo()
     Output
       <foo>
@@ -191,7 +192,7 @@
 # S7 object: displays objects with data nicely
 
     Code
-      text <- new_class("text", class_character)
+      text <- new_class("text", class_character, package = NULL)
       text("x")
     Output
       <text> chr "x"
diff --git a/tests/testthat/_snaps/inherits.md b/tests/testthat/_snaps/inherits.md
@@ -9,8 +9,8 @@
 # throws informative error
 
     Code
-      foo1 <- new_class("foo1")
-      foo2 <- new_class("foo2")
+      foo1 <- new_class("foo1", package = NULL)
+      foo2 <- new_class("foo2", package = NULL)
       check_is_S7(foo1(), foo2)
     Condition
       Error:
diff --git a/tests/testthat/_snaps/super.md b/tests/testthat/_snaps/super.md
@@ -1,7 +1,7 @@
 # super(): checks to
 
     Code
-      foo <- new_class("foo")
+      foo <- new_class("foo", package = NULL)
       super(foo(), class_character)
     Condition
       Error in `super()`:
diff --git a/tests/testthat/_snaps/union.md b/tests/testthat/_snaps/union.md
@@ -1,8 +1,8 @@
 # has useful print method
 
     Code
-      foo1 <- new_class("foo1")
-      foo2 <- new_class("foo2")
+      foo1 <- new_class("foo1", package = NULL)
+      foo2 <- new_class("foo2", package = NULL)
       new_union(foo1, foo2)
     Output
       <S7_union>: <foo1> or <foo2>
diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R
@@ -80,10 +80,15 @@ named_list <- function(...) {
 
 `add<-` <- `+`
 
-dbg <- function(..., .display = utils::str) {
+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)))) {
@@ -98,7 +103,7 @@ dbg <- function(..., .display = utils::str) {
     } else {
       sprintf("(%s) `%s`", name, expr)
     }
-    cat(label, ": ", sep = "")
+    cat(label, if (identical(.display, utils::str)) ": " else "\n", sep = "")
     .display(out <- eval(..i))
   }
 
@@ -127,9 +132,11 @@ dbg <- function(..., .display = utils::str) {
     cat(loc, "\n")
   } else {
     cat(sprintf("(from call: %s (srcfile missing))\n", trimws(
-      deparse1(sys.call(-2), width.cutoff = 60)
+      deparse1(sys.call(-2) %error% sys.call(-1), width.cutoff = 60)
     )))
   }
 
   invisible(out)
 }
+
+`%error%` <- function(x, y) tryCatch(x, error = function(e) y)
diff --git a/tests/testthat/test-S3.R b/tests/testthat/test-S3.R
@@ -3,7 +3,7 @@ test_that("new_S3_class has a print method", {
 })
 
 test_that("can construct objects that extend S3 classes", {
-  ordered2 <- new_class("ordered2", parent = class_factor)
+  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())
@@ -15,7 +15,7 @@ test_that("subclasses inherit validator", {
     function(.data) structure(.data, class = "foo"),
     function(x) if (!is.double(x)) "Underlying data must be a double"
   )
-  foo2 <- new_class("foo2", foo)
+  foo2 <- new_class("foo2", foo, package = NULL)
 
   expect_snapshot(error = TRUE, foo2("a"))
 })
diff --git a/tests/testthat/test-class-spec.R b/tests/testthat/test-class-spec.R
@@ -1,5 +1,5 @@
 test_that("can work with S7 classes", {
-  klass <- new_class("klass")
+  klass <- new_class("klass", package = NULL)
   expect_equal(as_class(klass), klass)
 
   expect_equal(class_type(klass), "S7")
@@ -35,8 +35,8 @@ test_that("can work with S7 classes in packages", {
 })
 
 test_that("can work with unions", {
-  text <- new_class("text", class_character)
-  number <- new_class("number", class_double)
+  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)
 
@@ -144,7 +144,8 @@ test_that("can work with S3 classes", {
 
 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))
+  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"))
diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R
@@ -11,8 +11,8 @@ describe("S7 classes", {
   })
 
   it("print nicely", {
-    foo1 <- new_class("foo1", properties = list(x = class_integer, y = class_integer))
-    foo2 <- new_class("foo2", foo1)
+    foo1 <- new_class("foo1", properties = list(x = class_integer, y = class_integer), package = NULL)
+    foo2 <- new_class("foo2", foo1, package = NULL)
 
     expect_snapshot({
       foo2
@@ -85,8 +85,8 @@ describe("abstract classes", {
     })
   })
   it("can construct concrete subclasses", {
-    foo1 <- new_class("foo1", abstract = TRUE)
-    foo2 <- new_class("foo2", parent = foo1)
+    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", {
@@ -96,9 +96,10 @@ describe("abstract classes", {
       abstract = TRUE,
       validator = function(self) {
         if (self@x == 2) "@x has bad value"
-      }
+      },
+      package = NULL
     )
-    foo2 <- new_class("foo2", parent = foo1)
+    foo2 <- new_class("foo2", parent = foo1, package = NULL)
     expect_no_error(foo2(x = 1))
     expect_snapshot(foo2(x = 2), error = TRUE)
   })
@@ -112,7 +113,8 @@ describe("new_object()", {
   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"
+      validator = function(self) if (self@x < 0) "x must be positive",
+      package = NULL
     )
 
     expect_snapshot(error = TRUE, {
@@ -136,23 +138,24 @@ describe("new_object()", {
 
 describe("S7 object", {
   it("has an S7 and S3 class", {
-    foo <- new_class("foo")
+    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))
+      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)
+      text <- new_class("text", class_character, package = NULL)
       text("x")
       str(list(text("x")))
     })
@@ -162,7 +165,8 @@ describe("S7 object", {
     foo1 <- new_class(
       "foo1",
       parent = class_list,
-      properties = list(x = class_double, y = class_list)
+      properties = list(x = class_double, y = class_list),
+      package = NULL
     )
     expect_snapshot(
       foo1(
@@ -213,8 +217,8 @@ describe("default constructor", {
   })
 
   it("initializes property with S7 object", {
-    foo1 <- new_class("foo1")
-    foo2 <- new_class("foo2", properties = list(x = foo1))
+    foo1 <- new_class("foo1", package = NULL)
+    foo2 <- new_class("foo2", properties = list(x = foo1), package = NULL)
     x <- foo2()
     expect_s3_class(x@x, "foo1")
   })
diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R
@@ -164,7 +164,7 @@ test_that("can create constructors with missing or lazy defaults", {
 
 test_that("Dynamic settable properties are included in constructor", {
   Foo <- new_class(
-    name = "Foo",
+    name = "Foo", package = NULL,
     properties = list(
       dynamic_settable = new_property(
         class_numeric,
diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R
@@ -1,6 +1,6 @@
 test_that("can register convert methods", {
   local_methods(convert)
-  converttest <- new_class("converttest")
+  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"
 
@@ -25,17 +25,17 @@ describe("fallback convert", {
   local_methods(convert)
 
   it("can convert to own class", {
-    foo1 <- new_class("foo1")
-    foo2 <- new_class("foo2", foo1)
+    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))
-    foo2 <- new_class("foo2", foo1, properties = list(y = class_double))
+    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"))
diff --git a/tests/testthat/test-generic.R b/tests/testthat/test-generic.R
@@ -31,7 +31,7 @@ test_that("check_dispatch_args() produces informative errors", {
 
 test_that("S7_generic printing", {
   foo1 <- new_generic("foo1", "x")
-  text <- new_class("text")
+  text <- new_class("text", package = NULL)
 
   method(foo1, class_character) <- function(x) 1
   method(foo1, text) <- function(x) 2
diff --git a/tests/testthat/test-inherits.R b/tests/testthat/test-inherits.R
@@ -15,8 +15,8 @@ test_that("checks that input is a class", {
 
 test_that("throws informative error", {
   expect_snapshot(error = TRUE, {
-    foo1 <- new_class("foo1")
-    foo2 <- new_class("foo2")
+    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)
diff --git a/tests/testthat/test-method-dispatch.R b/tests/testthat/test-method-dispatch.R
@@ -133,7 +133,7 @@ test_that("can dispatch on base 'union' types", {
 test_that("single dispatch fails with informative messages", {
   fail <- new_generic("fail", "x")
 
-  foo <- new_class("foo")
+  foo <- new_class("foo", package = NULL)
   Foo <- setClass("Foo", slots = list("x" = "numeric"))
   on.exit(S4_remove_classes("Foo"))
 
diff --git a/tests/testthat/test-method-introspect.R b/tests/testthat/test-method-introspect.R
diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R
diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R
diff --git a/tests/testthat/test-super.R b/tests/testthat/test-super.R
diff --git a/tests/testthat/test-union.R b/tests/testthat/test-union.R
diff --git a/tests/testthat/test-valid.R b/tests/testthat/test-valid.R
diff --git a/tests/testthat/test-zzz.R b/tests/testthat/test-zzz.R

Original file line number	Diff line number	Diff line change
`@@ -22,6 +22,13 @@ new_function <- function(args = NULL,`
`22`	`22`	`x`
`23`	`23`	`}`
`24`	`24`
	`25`	`+`
	`26`	`+topNamespaceName <- function(env = parent.frame()) {`
	`27`	`+ env <- topenv(env)`
	`28`	`+ if (isNamespace(env))`
	`29`	`+ getNamespaceName(env)`
	`30`	`+}`
	`31`	`+`
`25`	`32`	`is_string <- function(x) {`
`26`	`33`	`identical(class(x), "character") && length(x) == 1L && !is.na(x) && x != ""`
`27`	`34`	`}`
Original file line number	Diff line number	Diff line change
`@@ -107,7 +107,6 @@ register_S3_method <- function(generic, signature, method, envir = parent.frame(`
`107`	`107`	`}`
`108`	`108`
`109`	`109`	`class <- S7_class_name(signature[[1]])`
`110`		`- # dbg(generic$name, class, method, envir)`
`111`	`110`	`registerS3method(generic$name, class, method, envir)`
`112`	`111`	`}`
`113`	`112`