Fallback for older S3

Author: hadley

R/S3.R

@@ -147,6 +147,21 @@ is_S3_class <- function(x) {
   inherits(x, "S7_S3_class")
 }
 
+# Detect the stub constructor that `new_S3_class()` inserts when no constructor
+# is supplied. Needed as a fallback for `S7_S3_class` objects created by older
+# versions of S7.
+is_S3_stub_constructor <- function(constructor) {
+  if (!is.function(constructor)) {
+    return(FALSE)
+  }
+  call <- find_call(body(constructor), quote(sprintf))
+  if (is.null(call)) {
+    return(FALSE)
+  }
+  fmt <- call[[2]]
+  is.character(fmt) && grepl("doesn't have a constructor", fmt, fixed = TRUE)
+}
+
 # -------------------------------------------------------------------------
 # Pull out validation functions so hit by code coverage
 

R/class.R

@@ -270,8 +270,13 @@ is_class <- function(x) inherits(x, "S7_class")
 # A class you can't supply an instance of: an abstract S7 class, or an S3 class
 # registered without a constructor (e.g. a marker class like "gg" or "POSIXt").
 class_is_abstract <- function(class) {
-  (is_class(class) && class@abstract) ||
-    (is_S3_class(class) && isTRUE(class$abstract))
+  if (is_class(class)) {
+    class@abstract
+  } else if (is_S3_class(class)) {
+    class$abstract %||% is_S3_stub_constructor(class$constructor)
+  } else {
+    FALSE
+  }
 }
 
 check_parent <- function(parent, class, call = sys.call(-1L)) {

R/convert.R

@@ -169,7 +169,7 @@ convert_up <- function(from, to, call = sys.call(-1L)) {
   if (is_base_class(to)) {
     from <- zap_attr(from, c(from_props, "S7_class", "class"))
   } else if (is_S3_class(to)) {
-    if (to$abstract) {
+    if (class_is_abstract(to)) {
       msg <- sprintf("Can't convert to abstract class <%s>.", to$class[[1]])
       stop2(msg, call = call)
     }

tests/testthat/_snaps/convert.md

@@ -21,3 +21,4 @@
     Condition
       Error in `convert()`:
       ! Can't convert to abstract class <POSIXt>.
+

tests/testthat/test-class.R

@@ -167,6 +167,13 @@ describe("new_object()", {
     expect_no_error(Concrete(list(1, "A")))
   })
 
+  it("has fallback for S3 classes created by older S7 (#686)", {
+    old_s3 <- class_POSIXt
+    old_s3$abstract <- NULL
+    Foo <- new_class("Foo", parent = old_s3, constructor = \(x) new_object(x))
+    expect_no_error(Foo(list(1, "A")))
+  })
+
   it("errors if `.parent` is supplied but class has no parent", {
     NoParent <- new_class(
       "NoParent",