External S7 classes

NAMESPACE

@@ -14,6 +14,7 @@ S3method(print,S7_S3_class)
 S3method(print,S7_any)
 S3method(print,S7_base_class)
 S3method(print,S7_class)
+S3method(print,S7_external_class)
 S3method(print,S7_external_generic)
 S3method(print,S7_generic)
 S3method(print,S7_method)
@@ -68,6 +69,7 @@ export(method_explain)
 export(methods_register)
 export(new_S3_class)
 export(new_class)
+export(new_external_class)
 export(new_external_generic)
 export(new_generic)
 export(new_object)

R/class-spec.R

@@ -6,6 +6,7 @@
 #'
 #' @param x A class specification. One of the following:
 #'   * An S7 class (created by [new_class()]).
+#'   * An external S7 class (created by [new_external_class()]).
 #'   * An S7 union (created by [new_union()]).
 #'   * An S3 class (created by [new_S3_class()]).
 #'   * An S4 class (created by [methods::getClass()] or [methods::new()]).
@@ -41,7 +42,8 @@ is_foundation_class <- function(x) {
     is_base_class(x) ||
     is_S3_class(x) ||
     is_class_missing(x) ||
-    is_class_any(x)
+    is_class_any(x) ||
+    is_external_class(x)
 }
 
 class_type <- function(x) {
@@ -57,6 +59,8 @@ class_type <- function(x) {
     "S7"
   } else if (is_union(x)) {
     "S7_union"
+  } else if (is_external_class(x)) {
+    "S7_external"
   } else if (is_S3_class(x)) {
     "S7_S3"
   } else if (is_S4_class(x)) {
@@ -75,6 +79,7 @@ class_friendly <- function(x) {
     S7 = "an S7 class",
     S7_base = "a base type",
     S7_union = "an S7 union",
+    S7_external = "an external S7 class",
     S7_S3 = "an S3 class",
   )
 }
@@ -88,6 +93,7 @@ class_constructor <- function(.x, ...) {
     S7_base = .x$constructor,
     S7_union = class_constructor(.x$classes[[1]]),
     S7_S3 = .x$constructor,
+    S7_external = .x$constructor_fun(),
     stop(sprintf("Can't construct %s", class_friendly(.x)), call. = FALSE)
   )
 }
@@ -100,6 +106,7 @@ class_validate <- function(class, object) {
     S4 = methods::validObject,
     S7 = class@validator,
     S7_base = class$validator,
+    S7_external = class$constructor_fun()@validator,
     S7_S3 = class$validator,
     NULL
   )
@@ -120,6 +127,7 @@ class_desc <- function(x) {
     S7 = paste0("<", S7_class_name(x), ">"),
     S7_base = paste0("<", x$class, ">"),
     S7_union = oxford_or(unlist(lapply(x$classes, class_desc))),
+    S7_external = paste0("<", x$package, "::", x$name, ">"),
     S7_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"),
   )
 }
@@ -137,6 +145,7 @@ class_dispatch <- function(x) {
     S4 = S4_class_dispatch(methods::extends(x)),
     S7 = c(S7_class_name(x), class_dispatch(x@parent)),
     S7_base = c(x$class, "S7_object"),
+    S7_external = class_dispatch(x$constructor_fun()),
     S7_S3 = c(x$class, "S7_object"),
     stop("Unsupported")
   )
@@ -182,13 +191,16 @@ class_inherits <- function(x, what) {
     S7 = inherits(x, "S7_object") && inherits(x, S7_class_name(what)),
     S7_base = what$class == base_class(x),
     S7_union = any(vlapply(what$classes, class_inherits, x = x)),
+    S7_external = class_inherits(x, what$constructor_fun()),
     # This is slightly too crude as we really want them to be in the same
     # order and contiguous, but it's probably close enough for practical
     # purposes
     S7_S3 = !isS4(x) && all(what$class %in% class(x)),
   )
 }
 
+# object ------------------------------------------------------------------
+
 obj_type <- function(x) {
   if (identical(x, quote(expr = ))) {
     "missing"

R/class.R

@@ -113,6 +113,14 @@ new_class <- function(
   # Don't check arguments for S7_object
   if (!is.null(parent)) {
     check_can_inherit(parent)
+
+    # Automatically use an external class if appropriate
+    if (!is.null(package) && is_class(parent)) {
+      if (!is.null(parent@package) && !identical(parent@package, package)) {
+        parent <- new_external_class(parent@package, parent@name)
+      }
+    }
+
     if (!is.null(package)) {
       check_name(package)
     }
@@ -128,30 +136,44 @@ new_class <- function(
   }
 
   # Combine properties from parent, overriding as needed
-  all_props <- attr(parent, "properties", exact = TRUE) %||% list()
   new_props <- as_properties(properties)
-  all_props[names(new_props)] <- new_props
-
-  if (is.null(constructor)) {
-    constructor <- new_constructor(parent, all_props)
+  if (is_external_class(parent)) {
+    # TODO: cache this so only computed once per session
+    properties <- function() {
+      inherit_properties(parent$constructor_fun(), new_props)
+    }
+    constructor <- constructor %||% new_dynamic_constructor(parent, properties)
+  } else {
+    my_props <- inherit_properties(parent, new_props)
+    properties <- function() {
+      my_props
+    }
+    constructor <- constructor %||% new_constructor(parent, my_props)
   }
 
   object <- constructor
   # Must synchronise with prop_names
   attr(object, "name") <- name
   attr(object, "parent") <- parent
   attr(object, "package") <- package
-  attr(object, "properties") <- all_props
+  attr(object, "properties") <- properties
   attr(object, "abstract") <- abstract
   attr(object, "constructor") <- constructor
   attr(object, "validator") <- validator
   class(object) <- c("S7_class", "S7_object")
 
-  global_variables(names(all_props))
+  global_variables(names(properties()))
   object
 }
 globalVariables(c("name", "parent", "package", "properties", "abstract", "constructor", "validator"))
 
+inherit_properties <- function(parent, new) {
+  properties <- attr(parent, "properties", exact = TRUE) %||% function() list()
+  properties <- properties()
+  properties[names(new)] <- new
+  properties
+}
+
 #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name)
 S7_class_name <- function(x) {
   paste(c(x@package, x@name), collapse = "::")
@@ -170,7 +192,7 @@ check_S7_constructor <- function(constructor) {
 
 #' @export
 print.S7_class <- function(x, ...) {
-  props <- x@properties
+  props <- x@properties()
   if (length(props) > 0) {
     prop_names <- format(names(props))
     prop_types <- format(vcapply(props, function(x) class_desc(x$class)))
@@ -217,7 +239,9 @@ c.S7_class <- function(...) {
   stop(msg, call. = FALSE)
 }
 
-can_inherit <- function(x) is_base_class(x) || is_S3_class(x) || is_class(x)
+can_inherit <- function(x) {
+  is_base_class(x) || is_S3_class(x) || is_class(x) || is_external_class(x)
+}
 
 check_can_inherit <- function(x, arg = deparse(substitute(x))) {
   if (!can_inherit(x)) {
@@ -243,7 +267,8 @@ is_class <- function(x) inherits(x, "S7_class")
 #' @rdname new_class
 #' @export
 new_object <- function(.parent, ...) {
-  class <- sys.function(-1)
+  class <- sys.function(sys.parent())
+
   if (!inherits(class, "S7_class")) {
     stop("`new_object()` must be called from within a constructor")
   }
@@ -268,8 +293,9 @@ new_object <- function(.parent, ...) {
   # We have to fill in missing values after setting the initial properties,
   # because custom setters might set property values
   missing_props <- setdiff(nms, union(supplied_props, names(attributes(object))))
+  properties <- class@properties()
   for (prop in missing_props) {
-    prop(object, prop, check = FALSE) <- prop_default(class@properties[[prop]])
+    prop(object, prop, check = FALSE) <- prop_default(properties[[prop]])
   }
 
   # Don't need to validate if parent class already validated,

R/constructor.R

@@ -43,6 +43,30 @@ new_constructor <- function(parent, properties) {
   new_function(args, body, env)
 }
 
+new_dynamic_constructor <- function(parent, properties_fun) {
+  constructor_fun <- parent$constructor_fun
+  force(properties_fun)
+
+  function(...) {
+    parent_class <- constructor_fun()
+    args_info <- constructor_args(parent_class, properties_fun())
+
+    args <- list(...)
+    parent_args <- dynamic_args(args, args_info$parent)
+    self_args <- dynamic_args(args, args_info$self)
+
+    parent_obj <- do.call("parent_class", parent_args)
+    do.call("new_object", c(list(parent_obj), self_args))
+  }
+}
+dynamic_args <- function(args, selected) {
+  missing <- setdiff(selected, names(args))
+  args[missing] <- missing_args(missing)
+
+  args[selected]
+}
+
+
 constructor_args <- function(parent, properties = list()) {
   parent_args <- names2(formals(class_constructor(parent)))
 
@@ -52,7 +76,7 @@ constructor_args <- function(parent, properties = list()) {
   if (is_class(parent) && !parent@abstract) {
     # Remove any parent properties; can't use parent_args() since the constructor
     # might automatically set some properties.
-    self_args <- setdiff(self_args, names2(parent@properties))
+    self_args <- setdiff(self_args, names2(parent@properties()))
   }
 
   list(

R/convert.R

@@ -76,7 +76,7 @@ convert <- function(from, to, ...) {
     if (is.null(from_class)) {
       from_props <- character()
     } else {
-      from_props <- names(from_class@properties)
+      from_props <- names(from_class@properties())
     }
 
     if (is_base_class(to)) {
@@ -85,7 +85,7 @@ convert <- function(from, to, ...) {
       from <- zap_attr(from, c(from_props, "S7_class"))
       class(from) <- to$class
     } else if (is_class(to)) {
-      from <- zap_attr(from, setdiff(from_props, names(to@properties)))
+      from <- zap_attr(from, setdiff(from_props, names(to@properties())))
       attr(from, "S7_class") <- to
       class(from) <- class_dispatch(to)
     } else {

R/external-class.R

@@ -0,0 +1,72 @@
+#' Classes from other packages
+#'
+#' @description
+#' You need an explicit external class when you want extend a class defined in
+#' another package. An external class ensures that the class definition from
+#' the other package is not literally inlined in your package, ensuring that
+#' when the other package changes your package doesn't need to be rebuilt to
+#' get those changes.
+#'
+#' [new_class()] will automatically convert an S7 class to an external class
+#' if its `package` property has been set, and it's different to the `package`
+#' of the subclass. This should ensure that extending a class in another package
+#' just works without you having to do anything extra.
+#'
+#' Extending a class creates a hard requirement on the package that defines it;
+#' i.e. you must list the package in the `Imports` field in your package's
+#' `DESCRIPTION`.
+#'
+#' @param package Package the class is defined in.
+#' @param name Name of class, as a string.
+#' @param constructor_fun A zero-argument function that yields the constructor
+#'   of the external class. For expert use only.
+#' @returns An S7 external class, i.e. a list with class
+#'   `S7_external_class`.
+#' @export
+#' @examples
+#' foo <- new_class("foo", properties = list(x = class_integer))
+#' foo_ex <- new_external_class("S7", "foo", function() foo)
+#'
+#' foo2 <- new_class("foo", parent = foo_ex)
+#' foo2()
+new_external_class <- function(package,
+                               name,
+                               constructor_fun = NULL) {
+
+  check_name(package)
+  check_name(name)
+
+  if (is.null(constructor_fun)) {
+    constructor_fun <- function() getExportedValue(package, name)
+  } else {
+    check_function(constructor_fun, alist())
+  }
+
+  constructor <- constructor_fun()
+  if (!is_class(constructor)) {
+    stop("`constructor_fun()` must yield an S7 class")
+  }
+
+  out <- list(
+    package = package,
+    name = name,
+    constructor_fun = constructor_fun
+  )
+  class(out) <- "S7_external_class"
+  out
+}
+
+#' @export
+print.S7_external_class <- function(x, ...) {
+  cat(
+    "<S7_external_class> ",
+    x$package, "::", x$name, "\n",
+    sep = ""
+  )
+  invisible(x)
+}
+
+
+is_external_class <- function(x) {
+  inherits(x, "S7_external_class")
+}

R/property.R

@@ -186,7 +186,8 @@ prop_val <- function(object, name) {
 # Get underlying property object from class
 prop_obj <- function(object, name) {
   class <- S7_class(object)
-  attr(class, "properties")[[name]]
+  if (is.null(class)) return()
+  attr(class, "properties")()[[name]]
 }
 
 #' @rdname prop
@@ -316,7 +317,7 @@ prop_names <- function(object) {
     c("name", "parent", "package", "properties", "abstract", "constructor", "validator")
   } else {
     class <- S7_class(object)
-    props <- attr(class, "properties", exact = TRUE)
+    props <- attr(class, "properties", exact = TRUE)()
     if (length(props) == 0) {
       character()
     } else {

R/union.R

@@ -61,6 +61,7 @@ on_load_define_or_methods <- function() {
   registerS3method("|", "S7_base_class", `|.S7_class`)
   registerS3method("|", "S7_S3_class", `|.S7_class`)
   registerS3method("|", "S7_any", `|.S7_class`)
+  registerS3method("|", "S7_external_class", `|.S7_class`)
   registerS3method("|", "S7_missing", `|.S7_class`)
   registerS3method("|", "classGeneratorFunction", `|.S7_class`)
   registerS3method("|", "ClassUnionRepresentation", `|.S7_class`)

R/valid.R

@@ -103,7 +103,7 @@ validate <- function(object, recursive = TRUE, properties = TRUE) {
 validate_properties <- function(object, class) {
   errors <- character()
 
-  for (prop in class@properties) {
+  for (prop in class@properties()) {
     # Don't validate dynamic properties
     if (!is.null(prop$getter)) {
       next

_pkgdown.yml

@@ -29,13 +29,17 @@ reference:
   - method
   - method_explain
   - methods_register
-  - new_external_generic
   - new_S3_class
   - S4_register
   - S7_class
   - base_classes
   - class_missing
 
+- title: Packages
+  contents:
+  - new_external_class
+  - new_external_generic
+
 articles:
 - title: Learn S7
   navbar: ~