diff --git a/NEWS.md b/NEWS.md index cd091f86..b9b34a68 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,6 @@ * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646). * `method<-` now accepts `NULL` to unregister an existing method, e.g. `method(foo, class_character) <- NULL` (#613). -* `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). * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595). * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604). * `convert()` now falls back to the corresponding `as.*()` function (e.g. `as.character()`) when converting to a base type like `class_character` and no method or inheritance-based default applies, so `convert(1, class_character)` works out of the box (#472). @@ -20,6 +19,7 @@ * `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). * New `prop_info()` returns a data frame summarising the properties of an S7 object or class, with one row per property and columns for name, default, class, getter, setter, and validator (#551). +* `print()` now shows property defaults inline (`= "value"`) and annotates read-only properties (`[read-only]`) (#439). * `prop()` and `prop<-()` errors from custom getters and setters now report a synthetic `@` call, making it easier to see which property triggered the error (#536, #627, #638). * `prop()` no longer leaves an object in a broken state when a custom getter signals an error (#520, #640, #638). * `prop<-()` no longer fails when assigning a call or symbol to a property (#511, #633, #638). diff --git a/R/class.R b/R/class.R index 39186a69..692d3f23 100644 --- a/R/class.R +++ b/R/class.R @@ -189,9 +189,19 @@ check_S7_constructor <- function(constructor, call = sys.call(-1L)) { print.S7_class <- function(x, ...) { props <- x@properties if (length(props) > 0) { - prop_names <- format(names(props)) - prop_types <- format(vcapply(props, function(x) class_desc(x$class))) - prop_fmt <- paste0(" $ ", prop_names, ": ", prop_types, "\n", collapse = "") + prop_names <- names(props) + prop_defaults <- vcapply(props, prop_default_desc, package = x@package) + prop_types <- vcapply(props, function(p) class_desc(p$class)) + suffix <- ifelse(prop_defaults == "", "", paste0(" ", prop_defaults)) + prop_fmt <- paste0( + " $ ", + prop_names, + ": ", + prop_types, + suffix, + "\n", + collapse = "" + ) } else { prop_fmt <- "" } diff --git a/R/property.R b/R/property.R index 6aa2e971..33d9e57c 100644 --- a/R/property.R +++ b/R/property.R @@ -178,6 +178,35 @@ prop_default <- function(prop, envir, package) { prop$default %||% class_construct_expr(prop$class, envir, package) } +prop_default_desc <- function(prop, package = NULL) { + if (prop_is_read_only(prop)) { + return("[read-only]") + } + + if (!is.null(prop$default)) { + paste0("= ", deparse1(prop$default)) + } else { + desc <- class_default_desc(prop$class, package) + if (is.null(desc)) "" else paste0("= ", desc) + } +} + +# A clean, displayable string for a property's implicit default, or `NULL` if +# the class has no meaningful default (e.g. `class_any`, `class_missing`). +class_default_desc <- function(class, package = NULL) { + type <- class_type(class) + + expr <- switch( + type, + NULL = "NULL", + S7_base = deparse1(class_construct_expr(class, package = package)), + S7 = deparse1(call(class@name)), + S7_union = class_default_desc(class$classes[[1]], package), + S4 = deparse1(call(class@className)), + NULL + ) +} + #' Get/set a property #' #' - `prop(x, "name")` / `prop@name` get the value of the a property, diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index e6c19d8c..95192945 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -8,8 +8,8 @@ @ constructor: function(x, y) {...} @ validator : @ properties : - $ x: - $ y: + $ x: = integer(0) + $ y: = integer(0) Code str(foo2) Output @@ -52,6 +52,23 @@ @ validator : @ properties : +# S7 classes / shows property defaults and read-only annotations + + Code + Person + Output + class + @ parent : + @ constructor: function(implicit_default, implicit_complex, implicit_S7, default_value, default_expr) {...} + @ validator : + @ properties : + $ implicit_default: = character(0) + $ implicit_complex: S3 + $ implicit_S7: = Address() + $ default_value: = "" + $ default_expr: S3 = Sys.Date() + $ read_only: [read-only] + # S7 classes / checks inputs Code diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md index bbb0ce25..845b4da2 100644 --- a/tests/testthat/_snaps/property.md +++ b/tests/testthat/_snaps/property.md @@ -110,13 +110,13 @@ @ constructor: function(anything, null, base, S3, S4, S7, S7_union) {...} @ validator : @ properties : - $ anything: - $ null : - $ base : - $ S3 : S3 - $ S4 : S4 - $ S7 : - $ S7_union: or + $ anything: + $ null: = NULL + $ base: = integer(0) + $ S3: S3 + $ S4: S4 = class_S4() + $ S7: = class_S7() + $ S7_union: or = integer(0) --- diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 1cb46c5f..984eb952 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -32,6 +32,23 @@ describe("S7 classes", { expect_snapshot(foo) }) + it("shows property defaults and read-only annotations", { + Address <- new_class("Address", package = "S7") + Person <- new_class( + "Person", + properties = list( + implicit_default = new_property(class_character), + implicit_complex = new_property(class_Date), + implicit_S7 = new_property(Address), + default_value = new_property(class_character, default = ""), + default_expr = new_property(class_Date, default = quote(Sys.Date())), + read_only = new_property(getter = \(self) Sys.Date() - self@birthdate) + ), + package = "S7" + ) + expect_snapshot(Person) + }) + it("checks inputs", { expect_snapshot(error = TRUE, { new_class(1)