Merge pull request #438 from RConsortium/new-constructor-defaults

Updates to default constructor

.Rbuildignore

@@ -15,3 +15,6 @@
 ^pkgdown$
 ^cran-comments\.md$
 ^CRAN-SUBMISSION$
+^compile_commands\.json$
+^\.cache$
+^\.vscode$

.gitignore

@@ -3,3 +3,6 @@ script.R
 inst/doc
 docs
 .Rhistory
+compile_commands.json
+.cache
+.vscode

DESCRIPTION

@@ -45,4 +45,5 @@ Config/testthat/parallel: TRUE
 Config/testthat/start-first: external-generic
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
+Config/build/compilation-database: true

NEWS.md

@@ -1,5 +1,11 @@
 # S7 (development version)
 
+* The default object constructor returned by `new_class()` has been updated. 
+  It now accepts missing and lazy (promise) property defaults. Additionally, 
+  all custom property setters are now consistently invoked by the default 
+  constructor. If you're using S7 in an R package, you'll need to re-document 
+  to ensure that your docs match the updated usage (#438).
+
 * Fixed an issue where a custom property `getter()` would infinitely recurse 
   when accessing itself (reported in #403, fixed in #406).
 

R/aaa.R

@@ -0,0 +1,9 @@
+
+
+`%||%` <- function(x, y) if (is.null(x)) y else x
+
+new_function <- function(args = NULL,
+                         body = NULL,
+                         env = asNamespace("S7")) {
+  as.function.default(c(args, body) %||% list(NULL), env)
+}

R/base.R

@@ -1,16 +1,16 @@
 new_base_class <- function(name, constructor_name = name) {
   force(name)
 
-  constructor <- function(.data = class_missing) {
-    if (is_class_missing(.data)) {
-      .data <- base_default(name)
-    }
-    .data
-  }
+  constructor <- new_function(
+    args = list(.data = base_default(name)),
+    body = quote(.data),
+    env = baseenv()
+  )
 
   validator <- function(object) {
     if (base_class(object) != name) {
-      sprintf("Underlying data must be <%s> not <%s>", name, base_class(object))
+      sprintf("Underlying data must be <%s> not <%s>",
+              name, base_class(object))
     }
   }
 
@@ -35,8 +35,8 @@ base_default <- function(type) {
     list = list(),
     expression = expression(),
 
-    `function` = function() {},
-    environment = new.env(parent = emptyenv())
+    `function` = quote(function() {}),
+    environment = quote(new.env(parent = emptyenv()))
 )}
 
 

R/class-spec.R

@@ -80,21 +80,75 @@ class_friendly <- function(x) {
   )
 }
 
-class_constructor <- function(.x, ...) {
+class_construct <- function(.x, ...) {
+  eval(class_construct_expr(.x, ...))
+}
+
+
+class_construct_expr <- function(.x, ...) {
+  f <- class_constructor(.x)
+  # 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, ...)))
+  }
+
+  # special case for `class_missing`
+  if (identical(body(f) -> fb, quote(expr =))) {
+    return(quote(expr =))
+  }
+
+  # `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, ...)))
+  }
+
+  # maybe unwrap body if it is a single expression wrapped in `{`
+  if (length(fb) == 2L && identical(fb[[1L]], quote(`{`)))
+    fb <- fb[[2L]]
+
+  # If all the all the work happens in the promise to the `.data` arg,
+  # return the `.data` expression.
+  ff <- formals(f)
+  if ((identical(fb, quote(.data))) &&
+      identical(names(ff), ".data")) {
+    return(ff$.data)
+  }
+
+  # if all the work happens in the function body, return the body.
+  if (is.null(ff)) {
+    return(fb)
+  }
+
+  #else, return a call to the constructor
+  as.call(list(f, ...))
+}
+
+class_constructor <- function(.x) {
   switch(class_type(.x),
-    NULL = function() NULL,
-    any = function() NULL,
-    S4 = function(...) methods::new(.x, ...),
-    S7 = .x,
-    S7_base = .x$constructor,
-    S7_union = class_constructor(.x$classes[[1]]),
-    S7_S3 = .x$constructor,
-    stop(sprintf("Can't construct %s", class_friendly(.x)), call. = FALSE)
+         NULL = function() NULL,
+         missing = new_function(, quote(expr =), baseenv()),
+         any = function() NULL,
+         S4 = function(...) methods::new(.x, ...),
+         S7 = .x,
+         S7_base = .x$constructor,
+         S7_union = class_constructor(.x$classes[[1]]),
+         S7_S3 = .x$constructor,
+         stop(sprintf("Can't construct %s", class_friendly(.x)), call. = FALSE)
   )
 }
-class_construct <- function(.x, ...) {
-  class_constructor(.x)(...)
-}
 
 class_validate <- function(class, object) {
   validator <- switch(class_type(class),

R/class.R

@@ -260,17 +260,9 @@ new_object <- function(.parent, ...) {
   attr(object, "S7_class") <- class
   class(object) <- class_dispatch(class)
 
-  supplied_props <- nms[!vlapply(args, is_class_missing)]
-  for (prop in supplied_props) {
-    prop(object, prop, check = FALSE) <- args[[prop]]
-  }
-
-  # 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))))
-  for (prop in missing_props) {
-    prop(object, prop, check = FALSE) <- prop_default(class@properties[[prop]])
-  }
+  # Set properties. This will potentially invoke custom property setters
+  for (name in names(args))
+    prop(object, name, check = FALSE) <- args[[name]]
 
   # Don't need to validate if parent class already validated,
   # i.e. it's a non-abstract S7 class

R/constructor.R

@@ -1,10 +1,11 @@
 new_constructor <- function(parent, properties) {
+  properties <- as_properties(properties)
   arg_info <- constructor_args(parent, properties)
-  self_args <- as_names(arg_info$self, named = TRUE)
+  self_args <- as_names(names(arg_info$self), named = TRUE)
 
   if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) {
     return(new_function(
-      args = missing_args(arg_info$self),
+      args = arg_info$self,
       body = new_call("new_object", c(list(quote(S7_object())), self_args)),
       env = asNamespace("S7")
     ))
@@ -13,16 +14,16 @@ new_constructor <- function(parent, properties) {
   if (is_class(parent)) {
     parent_name <- parent@name
     parent_fun <- parent
-    args <- missing_args(union(arg_info$parent, arg_info$self))
+    args <- modify_list(arg_info$parent, arg_info$self)
   } else if (is_base_class(parent)) {
     parent_name <- parent$constructor_name
     parent_fun <- parent$constructor
-    args <- missing_args(union(arg_info$parent, arg_info$self))
+    args <- modify_list(arg_info$parent, arg_info$self)
   } else if (is_S3_class(parent)) {
     parent_name <- paste0("new_", parent$class[[1]])
     parent_fun <- parent$constructor
     args <- formals(parent$constructor)
-    args[arg_info$self] <- missing_args(arg_info$self)
+    args[names(arg_info$self)] <- arg_info$self
   } else {
     # user facing error in S7_class()
     stop("Unsupported `parent` type", call. = FALSE)
@@ -33,7 +34,8 @@ new_constructor <- function(parent, properties) {
     args[names(args) == "..."] <- list(quote(expr = ))
   }
 
-  parent_args <- as_names(arg_info$parent, named = TRUE)
+  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))
 
@@ -44,34 +46,32 @@ new_constructor <- function(parent, properties) {
 }
 
 constructor_args <- function(parent, properties = list()) {
-  parent_args <- names2(formals(class_constructor(parent)))
+  parent_args <- formals(class_constructor(parent))
 
-  self_args <- names2(properties)
+  self_arg_nms <- names2(properties)
   # Remove dynamic arguments
-  self_args <- self_args[vlapply(properties, function(x) is.null(x$getter))]
+  self_arg_nms <- self_arg_nms[vlapply(properties, function(x) is.null(x$getter))]
+
   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_arg_nms <- setdiff(self_arg_nms, names2(parent@properties))
   }
 
-  list(
-    parent = parent_args,
-    self = self_args
+  self_args <- as.pairlist(lapply(
+    setNames(, self_arg_nms),
+    function(name) prop_default(properties[[name]]))
   )
+
+  list(parent = parent_args,
+       self = self_args)
 }
 
+
 # helpers -----------------------------------------------------------------
 
-new_function <- function(args, body, env) {
-  f <- function() {}
-  formals(f) <- args
-  body(f) <- body
-  environment(f) <- env
-  attr(f, "srcref") <- NULL
+is_property_dynamic <- function(x) is.function(x$getter)
 
-  f
-}
 missing_args <- function(names) {
   lapply(setNames(, names), function(i) quote(class_missing))
 }

R/property.R

@@ -7,7 +7,8 @@
 #'
 #' By specifying a `getter` and/or `setter`, you can make the property
 #' "dynamic" so that it's computed when accessed or has some non-standard
-#' behaviour when modified.
+#' behaviour when modified. Dynamic properties are not included as an argument
+#' to the default class constructor.
 #'
 #' @param class Class that the property must be an instance of.
 #'   See [as_class()] for details.
@@ -31,8 +32,10 @@
 #'   The validator will be called after the `class` has been verified, so
 #'   your code can assume that `value` has known type.
 #' @param default When an object is created and the property is not supplied,
-#'   what should it default to? If `NULL`, defaults to the "empty" instance
-#'   of `class`.
+#'   what should it default to? If `NULL`, it defaults to the "empty" instance
+#'   of `class`. This can also be a quoted call, which then becomes a standard
+#'   function promise in the default constructor, evaluated at the time the
+#'   object is constructed.
 #' @param name Property name, primarily used for error messages. Generally
 #'   don't need to set this here, as it's more convenient to supply as a
 #'   the element name when defining a list of properties. If both `name`
@@ -59,9 +62,14 @@
 #' my_clock <- clock()
 #' my_clock@now; Sys.sleep(1)
 #' my_clock@now
-#' # This property is read only
+#' # This property is read only, because there is a 'getter' but not a 'setter'
 #' try(my_clock@now <- 10)
 #'
+#' # Because the property is dynamic, it is not included as an
+#' # argument to the default constructor
+#' try(clock(now = 10))
+#' args(clock)
+#'
 #' # These can be useful if you want to deprecate a property
 #' person <- new_class("person", properties = list(
 #'   first_name = class_character,
@@ -81,14 +89,37 @@
 #' hadley@firstName
 #' hadley@firstName <- "John"
 #' hadley@first_name
+#'
+#' # Properties can have default values that are quoted calls.
+#' # These become standard function promises in the default constructor,
+#' # evaluated at the time the object is constructed.
+#' stopwatch <- new_class("stopwatch", properties = list(
+#'   starttime = new_property(class = class_POSIXct, default = quote(Sys.time())),
+#'   totaltime = new_property(getter = function(self)
+#'     difftime(Sys.time(), self@starttime, units = "secs"))
+#' ))
+#' args(stopwatch)
+#' round(stopwatch()@totaltime)
+#' round(stopwatch(Sys.time() - 1)@totaltime)
+#'
+#' # Properties can also have a 'missing' default value, making them
+#' # required arguments to the default constructor.
+#' # You can generate a missing arg with `quote(expr =)` or `rlang::missing_arg()`
+#' Person <- new_class("Person", properties = list(
+#'   name = new_property(class_character, default = quote(expr = ))
+#' ))
+#' try(Person())
+#' Person("Alice")
 new_property <- function(class = class_any,
                          getter = NULL,
                          setter = NULL,
                          validator = NULL,
                          default = NULL,
                          name = NULL) {
   class <- as_class(class)
-  if (!is.null(default) && !class_inherits(default, class)) {
+  if (!is.null(default) &&
+      !(is.call(default) || is.symbol(default)) && # allow promises
+      !class_inherits(default, class)) {
     msg <- sprintf("`default` must be an instance of %s, not a %s", class_desc(class), obj_desc(default))
     stop(msg)
   }
@@ -131,7 +162,7 @@ str.S7_property <- function(object, ..., nest.lev = 0) {
 }
 
 prop_default <- function(prop) {
-  prop$default %||% class_construct(prop$class)
+  prop$default %||% class_construct_expr(prop$class)
 }
 
 #' Get/set a property

R/special.R

@@ -10,10 +10,12 @@
 #' @examples
 #' foo <- new_generic("foo", "x")
 #' method(foo, class_numeric) <- function(x) "number"
+#' method(foo, class_missing) <- function(x) "missing"
 #' method(foo, class_any) <- function(x) "fallback"
 #'
 #' foo(1)
 #' foo()
+#' foo("")
 class_missing <- structure(list(), class = "S7_missing")
 
 is_class_missing <- function(x) inherits(x, "S7_missing")