Run class_validate() on properties (#675)

* Fix bug in `class_POSIXct` thus revealed
* Fix bug in S4 validation thus revealed

Author: hadley

NEWS.md

@@ -1,6 +1,7 @@
 # S7 (development version)
 
 * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646).
+* `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401).
 * Base type wrappers like `class_integer` now define their constructor and validator in the S7 namespace. (#553).
 * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595).
 * `convert()` no longer automatically converts between sibling classes (classes that merely share a common ancestor); the default downcast now applies only when `to` is genuinely a descendant of `from`'s class (#509).
@@ -15,6 +16,7 @@
 * `new_object()` now gives an informative error when `.parent` is a class specification rather than an instance of the parent class (#409).
 * `new_object()` no longer materialises ALTREP parent values (e.g. `seq_len()`), so constructing an S7 object that wraps a large compact integer sequence is now O(1) in memory instead of O(n) (@kschaubroeck, #607).
 * `new_object()` no longer re-runs property validators for properties inherited unchanged from an already-validated parent class, so constructing an instance of a deeply nested class hierarchy validates each property exactly once (#539).
+* `new_property()` now runs the property class's own validator when checking a value, not just the structural class check, so a property restricted to an S3 class (e.g. `class_factor`) now enforces constraints that aren't visible in `class()` (#401).
 * `new_property()` now accepts a `setter` that takes `self`, `name`, and `value` making it easy to reuse the same definition for multiple properties (#552).
 * `new_S3_class()` objects now work with `inherits()` (and other functions that use `nameOfClass()`) in R 4.3 and later (@lawremi, #521).
 * `print(<S7_class>)` now shows property defaults inline (`= "value"`) and annotates read-only properties (`[read-only]`) (#439).

R/S3.R

@@ -184,9 +184,9 @@ validate_POSIXct <- function(self) {
     return("Underlying data must be numeric")
   }
 
-  tz <- attr(self, "tz")
-  if (!is.character(tz) || length(tz) != 1) {
-    return("attr(, 'tz') must be a single string")
+  tz <- attr(self, "tzone", exact = TRUE)
+  if (!is.null(tz) && (!is.character(tz) || length(tz) != 1)) {
+    return("attr(, 'tzone') must be NULL or a single string")
   }
 }
 

R/class-spec.R

@@ -192,7 +192,10 @@ class_constructor <- function(.x) {
 class_validate <- function(class, object) {
   validator <- switch(
     class_type(class),
-    S4 = methods::validObject,
+    S4 = function(object) {
+      check <- methods::validObject(object, test = TRUE)
+      if (isTRUE(check)) NULL else check
+    },
     S7 = class@validator,
     S7_base = class$validator,
     S7_S3 = class$validator,

R/property.R

@@ -278,6 +278,11 @@ prop_validate <- function(prop, value, object = NULL) {
     ))
   }
 
+  class_error <- class_validate(prop$class, value)
+  if (length(class_error) > 0) {
+    return(paste0(prop_label(object, prop$name), ": ", class_error))
+  }
+
   if (is.null(validator <- prop$validator)) {
     return(NULL)
   }

tests/testthat/_snaps/S3.md

@@ -63,13 +63,13 @@
 # catches invalid POSIXct
 
     Code
-      validate_POSIXct(structure("x", tz = "UTC"))
+      validate_POSIXct(structure("x", tzone = "UTC"))
     Output
       [1] "Underlying data must be numeric"
     Code
-      validate_POSIXct(structure(1, tz = 1))
+      validate_POSIXct(structure(1, tzone = 1))
     Output
-      [1] "attr(, 'tz') must be a single string"
+      [1] "attr(, 'tzone') must be NULL or a single string"
 
 # catches invalid data.frame
 

tests/testthat/_snaps/property.md

@@ -212,6 +212,24 @@
       ! <foo> object properties are invalid:
       - @x must be length 1
 
+# property validation runs the class's own validator
+
+    Code
+      Foo(x = bad)
+    Condition
+      Error in `Foo()`:
+      ! <Foo> object properties are invalid:
+      - @x: Not enough 'levels' for underlying data
+
+# property validation runs an S4 class's validity method
+
+    Code
+      Foo(x = bad)
+    Condition
+      Error in `Foo()`:
+      ! <Foo> object properties are invalid:
+      - @x: n must be positive
+
 # prop<- won't infinitly recurse on a custom setter
 
     Code

tests/testthat/test-S3.R

@@ -67,9 +67,10 @@ test_that("catches invalid dates", {
 
 test_that("catches invalid POSIXct", {
   expect_snapshot({
-    validate_POSIXct(structure("x", tz = "UTC"))
-    validate_POSIXct(structure(1, tz = 1))
+    validate_POSIXct(structure("x", tzone = "UTC"))
+    validate_POSIXct(structure(1, tzone = 1))
   })
+  expect_null(validate_POSIXct(Sys.time()))
 })
 
 test_that("catches invalid data.frame", {

tests/testthat/test-property.R

@@ -484,6 +484,33 @@ test_that("can validate with custom validator", {
   })
 })
 
+test_that("property validation runs the class's own validator", {
+  Foo <- new_class("Foo", package = NULL, properties = list(x = class_factor))
+
+  # A malformed factor passes the structural check (its class is "factor")
+  # but fails the factor validator because it has too few levels.
+  bad <- structure(1:3, levels = "a", class = "factor")
+  expect_snapshot(Foo(x = bad), error = TRUE)
+})
+
+test_that("property validation runs an S4 class's validity method", {
+  PosNum <- methods::setClass(
+    "PosNum",
+    slots = c(n = "numeric"),
+    validity = function(object) {
+      if (object@n <= 0) "n must be positive" else TRUE
+    }
+  )
+  on.exit(S4_remove_classes("PosNum"))
+  Foo <- new_class("Foo", package = NULL, properties = list(x = PosNum))
+
+  # An S4 object that passes the structural check but fails its own validity
+  # method is rejected
+  bad <- PosNum(n = 1)
+  bad@n <- -5
+  expect_snapshot(Foo(x = bad), error = TRUE)
+})
+
 test_that("prop<- won't infinitly recurse on a custom setter", {
   chattily_sync_ab <- function(self, value) {
     cat("Starting syncup with value:", value, "\n")