Automatically detect package name in new_class(package=)

R/aaa.R

@@ -13,3 +13,11 @@ new_function <- function(args = NULL,
   x[[length(x) + 1L]] <- value
   x
 }
+
+topNamespaceName <- function(env = parent.frame()) {
+  env <- topenv(env)
+  if (isNamespace(env))
+    getNamespaceName(env)
+  else
+    NULL
+}

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,

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

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:

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

tests/testthat/helper.R

@@ -93,10 +93,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)))) {
@@ -111,7 +116,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))
   }
 
@@ -140,9 +145,23 @@ 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)
+
+# prevent new_class() from creating `S7::` prefixed S3 class names in tests.
+local({
+  ns <- asNamespace("S7")
+  unlockBinding("topNamespaceName", ns)
+  .topNamespaceName <- ns$topNamespaceName
+  ns$topNamespaceName <- function(env = parent.frame) {
+    name <- .topNamespaceName(env)
+    if (is.null(name) || name == "S7") NULL else name
+  }
+  lockBinding("topNamespaceName", ns)
+})