Include Settable Properties in Default Constructor

R/class.R

@@ -253,16 +253,27 @@ new_object <- function(.parent, ...) {
   }
 
   args <- list(...)
-  nms <- names(args)
+  if ("" %in% names2(args)) {
+    stop("All arguments to `...` must be named")
+  }
+
+  has_setter <- vlapply(class@properties[names(args)], prop_has_setter)
 
   # TODO: Some type checking on `.parent`?
   object <- .parent
-  attr(object, "S7_class") <- class
-  class(object) <- class_dispatch(class)
 
-  # Set properties. This will potentially invoke custom property setters
-  for (name in names(args))
-    prop(object, name, check = FALSE) <- args[[name]]
+  attrs <- c(
+    list(class = class_dispatch(class), S7_class = class),
+    args[!has_setter],
+    attributes(object)
+  )
+  attrs <- attrs[!duplicated(names(attrs))]
+  attributes(object) <- attrs
+
+  # invoke custom property setters
+  prop_setter_vals <- args[has_setter]
+  for (name in names(prop_setter_vals))
+    prop(object, name, check = FALSE) <- prop_setter_vals[[name]]
 
   # Don't need to validate if parent class already validated,
   # i.e. it's a non-abstract S7 class

R/constructor.R

@@ -6,7 +6,12 @@ new_constructor <- function(parent, properties) {
   if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) {
     return(new_function(
       args = arg_info$self,
-      body = new_call("new_object", c(list(quote(S7_object())), self_args)),
+      body = as.call(c(quote(`{`),
+        # Force all promises here so that any errors are signaled from
+        # the constructor() call instead of the new_object() call.
+        unname(self_args),
+        new_call("new_object", c(list(quote(S7_object())), self_args))
+      )),
       env = asNamespace("S7")
     ))
   }
@@ -48,9 +53,10 @@ new_constructor <- function(parent, properties) {
 constructor_args <- function(parent, properties = list()) {
   parent_args <- formals(class_constructor(parent))
 
+  # Remove read-only properties
+  properties <- properties[!vlapply(properties, prop_is_read_only)]
+
   self_arg_nms <- names2(properties)
-  # Remove dynamic arguments
-  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

R/property.R

@@ -10,6 +10,9 @@
 #' behaviour when modified. Dynamic properties are not included as an argument
 #' to the default class constructor.
 #'
+#' See the "Properties: Common Patterns" section in `vignette("class-objects")`
+#' for more examples.
+#'
 #' @param class Class that the property must be an instance of.
 #'   See [as_class()] for details.
 #' @param getter An optional function used to get the value. The function
@@ -69,60 +72,14 @@
 #' # 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,
-#'   firstName = new_property(
-#'      getter = function(self) {
-#'        warning("@firstName is deprecated; please use @first_name instead", call. = FALSE)
-#'        self@first_name
-#'      },
-#'      setter = function(self, value) {
-#'        warning("@firstName is deprecated; please use @first_name instead", call. = FALSE)
-#'        self@first_name <- value
-#'        self
-#'      }
-#'    )
-#' ))
-#' hadley <- person(first_name = "Hadley")
-#' 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) &&
-      !(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)
-  }
+  check_prop_default(default, class)
 
   if (!is.null(getter)) {
     check_function(getter, alist(self = ))
@@ -147,6 +104,43 @@ new_property <- function(class = class_any,
   out
 }
 
+check_prop_default <- function(default, class, error_call = sys.call(-1)) {
+  if (is.null(default)) {
+    return() # always valid.
+  }
+
+  if (is.call(default)) {
+    # A promise default; delay checking until constructor called.
+    return()
+  }
+
+  if (is.symbol(default)) {
+    if (identical(default, quote(...))) {
+      # The meaning of a `...` prop default needs discussion
+      stop(simpleError("`default` cannot be `...`", error_call))
+    }
+    if (identical(default, quote(expr =))) {
+      # The meaning of a missing prop default needs discussion
+      stop(simpleError("`default` cannot be missing", error_call))
+    }
+
+    # other symbols are treated as promises
+    return()
+  }
+
+  if (class_inherits(default, class))
+    return()
+
+  msg <- sprintf("`default` must be an instance of %s, not a %s",
+                 class_desc(class), obj_desc(default))
+
+  stop(simpleError(msg, error_call))
+}
+
+stop.parent <- function(..., call = sys.call(-2)) {
+  stop(simpleError(.makeMessage(...), call))
+}
+
 is_property <- function(x) inherits(x, "S7_property")
 
 #' @export
@@ -484,3 +478,8 @@ as_property <- function(x, name, i) {
 prop_is_read_only <- function(prop) {
   is.function(prop$getter) && !is.function(prop$setter)
 }
+
+prop_has_setter <- function(prop) is.function(prop$setter)
+
+prop_is_dynamic <- function(prop) is.function(prop$getter)
+

tests/testthat/_snaps/constructor.md

@@ -4,13 +4,19 @@
       new_constructor(S7_object, list())
     Output
       function () 
-      new_object(S7_object())
+      {
+          new_object(S7_object())
+      }
       <environment: namespace:S7>
     Code
       new_constructor(S7_object, as_properties(list(x = class_numeric, y = class_numeric)))
     Output
       function (x = integer(0), y = integer(0)) 
-      new_object(S7_object(), x = x, y = y)
+      {
+          x
+          y
+          new_object(S7_object(), x = x, y = y)
+      }
       <environment: namespace:S7>
     Code
       foo <- new_class("foo", parent = class_character)
@@ -51,13 +57,18 @@
       new_constructor(foo1, list())
     Output
       function () 
-      new_object(S7_object())
+      {
+          new_object(S7_object())
+      }
       <environment: namespace:S7>
     Code
       new_constructor(foo1, as_properties(list(y = class_double)))
     Output
       function (y = numeric(0)) 
-      new_object(S7_object(), y = y)
+      {
+          y
+          new_object(S7_object(), y = y)
+      }
       <environment: namespace:S7>
 
 # can use `...` in parent constructor

tests/testthat/test-constructor.R

@@ -101,14 +101,15 @@ test_that("can create constructors with missing or lazy defaults", {
   Person <- new_class(
     name = "Person",
     properties = list(
-      # non-dynamic, default missing (required constructor arg)
-      first_name = new_property(class_character, default = quote(expr = )),
+      # non-dynamic, default error call (required constructor arg)
+      first_name = new_property(class_character, default = quote(stop(
+        'argument "first_name" is missing, with no default'))),
 
       # non-dynamic, static default (optional constructor arg)
       middle_name = new_property(class_character, default = ""),
 
-      # non-dynamic, default missing (required constructor arg) (same as first_name)
-      last_name = new_property(class_missing | class_character),
+      # non-dynamic, nullable character
+      last_name = new_property(NULL | class_character),
 
       # non-dynamic, but defaults to the value of another property
       nick_name = new_property(class_character, default = quote(first_name)),
@@ -133,15 +134,15 @@ test_that("can create constructors with missing or lazy defaults", {
   )
 
   expect_equal(formals(Person), as.pairlist(alist(
-    first_name = ,
+    first_name = stop('argument "first_name" is missing, with no default'),
     middle_name = "",
-    last_name = ,
+    last_name = NULL,
     nick_name = first_name,
     birthdate = Sys.Date()
   ))) # no age
 
   expect_error(Person(), 'argument "first_name" is missing, with no default')
-  expect_error(Person("Alice"), 'argument "last_name" is missing, with no default')
+  expect_null(Person("Alice")@last_name)
 
   p <- Person("Alice", ,"Smith")
 
@@ -158,3 +159,37 @@ test_that("can create constructors with missing or lazy defaults", {
   expect_error(p@birthdate <- as.Date('1970-01-01'),
                "Can\'t set read-only property Person@birthdate")
 })
+
+
+
+test_that("Dynamic settable properties are included in constructor", {
+  Foo <- new_class(
+    name = "Foo",
+    properties = list(
+      dynamic_settable = new_property(
+        class_numeric,
+        getter = function(self) self@dynamic_settable,
+        setter = function(self, value) {
+          self@dynamic_settable <- value
+          self
+        }
+      ),
+
+      dynamic_read_only = new_property(
+        class_numeric,
+        getter = function(self) 99,
+      )
+    )
+  )
+
+  expect_equal(formals(Foo), pairlist(dynamic_settable = numeric()))
+  expect_equal(Foo()@dynamic_settable, numeric())
+  expect_equal(Foo(3)@dynamic_settable, 3)
+
+  foo <- Foo()
+  expect_error(foo@dynamic_read_only <- 1,
+               "Can't set read-only property <Foo>@dynamic_read_only")
+  foo@dynamic_settable <- 1
+  expect_equal(foo@dynamic_settable, 1)
+
+})

tests/testthat/test-property.R

@@ -407,8 +407,9 @@ test_that("custom getters don't infinitely recurse", {
     )
   ))
 
+  expect_equal(someclass("foo")@someprop, "FOO")
   x <- someclass()
-  expect_null(x@someprop)
+  expect_equal(x@someprop, character())
   x@someprop <- "foo"
   expect_equal(x@someprop, "FOO")
 
@@ -429,8 +430,11 @@ test_that("custom setters can call custom getters", {
     )
   ))
 
+  x <- someclass("foo")
+  expect_equal(x@someprop, "FOO")
+
   x <- someclass()
-  expect_null(x@someprop)
+  expect_equal(x@someprop, character())
 
   x@someprop <- "foo"
   expect_equal(x@someprop, "FOO")