From 1ee3eb39cf585404f4131e4bf22d2c78d39daa92 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Sun, 31 May 2026 18:57:48 -0500 Subject: [PATCH] Initial matrix + array explorations --- NAMESPACE | 16 ++ NEWS.md | 2 + R/S3.R | 102 +------------ R/base-array.R | 276 ++++++++++++++++++++++++++++++++++ R/class-spec.R | 2 +- R/method-register.R | 10 +- R/property.R | 8 + R/zzz.R | 1 + _pkgdown.yml | 1 + man/base_arrays.Rd | 90 +++++++++++ man/base_s3_classes.Rd | 2 + tests/testthat/_snaps/S3.md | 6 +- tests/testthat/_snaps/base.md | 31 ++++ tests/testthat/test-S3.R | 6 +- tests/testthat/test-base.R | 91 +++++++---- 15 files changed, 511 insertions(+), 133 deletions(-) create mode 100644 R/base-array.R create mode 100644 man/base_arrays.Rd diff --git a/NAMESPACE b/NAMESPACE index c6e15e82..1ca89fd1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -50,25 +50,41 @@ export(class_POSIXct) export(class_POSIXlt) export(class_POSIXt) export(class_any) +export(class_array) export(class_atomic) export(class_call) export(class_character) +export(class_character_array) +export(class_character_matrix) export(class_complex) +export(class_complex_array) +export(class_complex_matrix) export(class_data.frame) export(class_double) +export(class_double_array) +export(class_double_matrix) export(class_environment) export(class_expression) export(class_factor) export(class_formula) export(class_function) export(class_integer) +export(class_integer_array) +export(class_integer_matrix) export(class_language) export(class_list) +export(class_list_array) +export(class_list_matrix) export(class_logical) +export(class_logical_array) +export(class_logical_matrix) +export(class_matrix) export(class_missing) export(class_name) export(class_numeric) export(class_raw) +export(class_raw_array) +export(class_raw_matrix) export(class_vector) export(convert) export(method) diff --git a/NEWS.md b/NEWS.md index cd091f86..61df7663 100644 --- a/NEWS.md +++ b/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_array` and `class_matrix` are new unions that, together with the element-typed `class_double_matrix`, `class_integer_array`, etc. (one per base vector type), let you subclass matrices and arrays, e.g. `new_class("my_matrix", class_double_matrix)`. Like `class_numeric`, `class_array` and `class_matrix` can be used in `method()` and `new_property()` but not as a `parent`, so you must pick an element type when subclassing (#401). * `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). @@ -17,6 +18,7 @@ * `super()` now works with S3 and S4 objects, not just S7 objects (#500). * `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 typed with a class like `class_double_matrix` enforces constraints (such as element type) 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). * 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). diff --git a/R/S3.R b/R/S3.R index 0932841e..59efd28e 100644 --- a/R/S3.R +++ b/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") } } @@ -218,56 +218,6 @@ validate_data.frame <- function(self) { } } -valid_dimnames <- function(self) { - dn <- dimnames(self) - if (is.null(dn)) { - TRUE - } else if (!is.list(dn) || length(dn) != length(dim(self))) { - FALSE - } else { - for (i in seq_along(dimnames(self))) { - if (is.null(dn[[i]])) { - next - } - if (!is.character(dn[[i]]) || length(dn[[i]]) != dim(self)[[i]]) { - return(FALSE) - } - } - } - TRUE -} - -validate_matrix <- function(self) { - if (!is.matrix(self)) { - # is.matrix() methods should only return TRUE if valid - "is.matrix(self) is FALSE" - } else if ( - !is.integer(dim(self)) || length(dim(self)) != 2L || !all(dim(self) >= 0L) - ) { - "dim(self) must be a non-negative integer vector of length 2" - } else if (!valid_dimnames(self)) { - "dimnames(self) must be NULL or a length 2 list of either NULL or a character vector of length equal to its corresponding dimension" - } -} - -validate_array <- function(self) { - if (is.array(self)) { - # is.array() methods should only return TRUE if valid - return(invisible(NULL)) - } - if ( - !is.integer(dim(self)) || length(dim(self)) == 0L || !all(dim(self) >= 0L) - ) { - return("dim(self) must be a non-empty non-negative integer vector") - } - if (!valid_dimnames(self)) { - return( - "dimnames(self) must be NULL or a list of either NULL or a character vector of length equal to its corresponding dimension" - ) - } - "is.array(self) is FALSE" -} - validate_formula <- function(self) { if (is.null(environment(self))) { return("environment(self) must be non-NULL") @@ -295,10 +245,9 @@ validate_formula <- function(self) { #' * `class_Date` for dates. #' * `class_factor` for factors. #' * `class_POSIXct`, `class_POSIXlt` and `class_POSIXt` for date-times. -# * `class_matrix` for matrices. -# * `class_array` for arrays. #' * `class_formula` for formulas. - +#' +#' Matrices and arrays are documented separately in [base_arrays]. #' #' @export #' @name base_s3_classes @@ -373,47 +322,6 @@ class_data.frame <- new_S3_class( validator = validate_data.frame ) -# @export -# @rdname base_s3_classes -# @format NULL -# @order 3 -class_matrix <- new_S3_class( - "matrix", - constructor = function( - .data = logical(), - nrow = NULL, - ncol = NULL, - byrow = FALSE, - dimnames = NULL - ) { - nrow <- nrow %||% NROW(.data) - if (is.null(ncol)) { - ncol <- NCOL(.data) - if (length(.data) != (nrow * ncol)) { - ncol <- length(.data) %/% nrow - } - } - matrix(.data, nrow, ncol, byrow, dimnames) - }, - validator = validate_matrix -) - -# @export -# @rdname base_s3_classes -# @format NULL -# @order 3 -class_array <- new_S3_class( - "array", - constructor = function( - .data = logical(), - dim = base::dim(.data) %||% length(.data), - dimnames = base::dimnames(.data) - ) { - array(.data, dim, dimnames) - }, - validator = validate_array -) - #' @export #' @rdname base_s3_classes #' @format NULL diff --git a/R/base-array.R b/R/base-array.R new file mode 100644 index 00000000..555cdb67 --- /dev/null +++ b/R/base-array.R @@ -0,0 +1,276 @@ +#' S7 wrappers for matrices and arrays +#' +#' @description +#' S7 bundles classes for matrices and arrays. Because the element type of a +#' matrix or array is independent of its dimensions, there is one class for +#' each base vector type: +#' +#' * `class_logical_matrix`, `class_integer_matrix`, `class_double_matrix`, +#' `class_complex_matrix`, `class_character_matrix`, `class_raw_matrix`, and +#' `class_list_matrix` for matrices. +#' * `class_logical_array`, `class_integer_array`, `class_double_array`, +#' `class_complex_array`, `class_character_array`, `class_raw_array`, and +#' `class_list_array` for arrays. +#' +#' `class_matrix` and `class_array` are unions of these element-typed classes. +#' Like other unions (e.g. [class_numeric]), they can be used in [method()] +#' and [new_property()] but not as a `parent` in [new_class()]. To subclass a +#' matrix or array you must pick an element type, e.g. +#' `new_class("my_matrix", class_double_matrix)`. +#' +#' @seealso [base_classes] and [base_s3_classes] for other classes that +#' provide compatibility with base types and S3 classes. +#' @return S7 classes wrapping around base matrices and arrays. +#' @name base_arrays +#' @order 0 +#' @examples +#' # Create an S7 class that extends a double matrix +#' Cov <- new_class("Cov", class_double_matrix) +#' Cov(matrix(c(1, 0.5, 0.5, 1), nrow = 2)) +#' +#' # `class_matrix` and `class_array` dispatch on any element type +#' n_dim <- new_generic("n_dim", "x") +#' method(n_dim, class_array) <- function(x) length(dim(x)) +#' n_dim(Cov(diag(3))) +NULL + +valid_dimnames <- function(self) { + dn <- dimnames(self) + if (is.null(dn)) { + TRUE + } else if (!is.list(dn) || length(dn) != length(dim(self))) { + FALSE + } else { + for (i in seq_along(dimnames(self))) { + if (is.null(dn[[i]])) { + next + } + if (!is.character(dn[[i]]) || length(dn[[i]]) != dim(self)[[i]]) { + return(FALSE) + } + } + TRUE + } +} + +validate_matrix <- function(self) { + if (!is.matrix(self)) { + # is.matrix() methods should only return TRUE if valid + "is.matrix(self) is FALSE" + } else if ( + !is.integer(dim(self)) || length(dim(self)) != 2L || !all(dim(self) >= 0L) + ) { + "dim(self) must be a non-negative integer vector of length 2" + } else if (!valid_dimnames(self)) { + "dimnames(self) must be NULL or a length 2 list of either NULL or a character vector of length equal to its corresponding dimension" + } +} + +validate_array <- function(self) { + if (is.array(self)) { + # is.array() methods should only return TRUE if valid + return(invisible(NULL)) + } + if ( + !is.integer(dim(self)) || length(dim(self)) == 0L || !all(dim(self) >= 0L) + ) { + return("dim(self) must be a non-empty non-negative integer vector") + } + if (!valid_dimnames(self)) { + return( + "dimnames(self) must be NULL or a list of either NULL or a character vector of length equal to its corresponding dimension" + ) + } + "is.array(self) is FALSE" +} + +# Construct an element-typed matrix or array S3 class. The element type is +# kept out of the `class` vector (which mirrors the implicit S3 class of a +# bare object, e.g. `c("matrix", "array")`) so that structural inheritance +# still matches base objects; instead it is enforced by the validator. +new_base_matrix <- function(type) { + is_type <- get(paste0("is.", type), envir = baseenv(), mode = "function") + + constructor <- function( + .data, + nrow = NULL, + ncol = NULL, + byrow = FALSE, + dimnames = NULL + ) { + nrow <- nrow %||% NROW(.data) + if (is.null(ncol)) { + ncol <- NCOL(.data) + if (length(.data) != (nrow * ncol)) { + ncol <- length(.data) %/% nrow + } + } + matrix(.data, nrow, ncol, byrow, dimnames) + } + formals(constructor)$.data <- call(type) + + out <- new_S3_class( + c("matrix", "array"), + constructor = constructor, + validator = function(self) { + validate_matrix(self) %||% + if (!is_type(self)) { + sprintf( + "Underlying data must be <%s> not <%s>", + type, + base_class(self) + ) + } + } + ) + out$desc <- sprintf("S3<%s matrix>", type) + out +} + +new_base_array <- function(type) { + is_type <- get(paste0("is.", type), envir = baseenv(), mode = "function") + + constructor <- function( + .data, + dim = base::dim(.data) %||% length(.data), + dimnames = base::dimnames(.data) + ) { + array(.data, dim, dimnames) + } + formals(constructor)$.data <- call(type) + + out <- new_S3_class( + "array", + constructor = constructor, + validator = function(self) { + validate_array(self) %||% + if (!is_type(self)) { + sprintf( + "Underlying data must be <%s> not <%s>", + type, + base_class(self) + ) + } + } + ) + out$desc <- sprintf("S3<%s array>", type) + out +} + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_logical_matrix <- new_base_matrix("logical") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_integer_matrix <- new_base_matrix("integer") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_double_matrix <- new_base_matrix("double") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_complex_matrix <- new_base_matrix("complex") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_character_matrix <- new_base_matrix("character") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_raw_matrix <- new_base_matrix("raw") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_list_matrix <- new_base_matrix("list") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_logical_array <- new_base_array("logical") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_integer_array <- new_base_array("integer") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_double_array <- new_base_array("double") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_complex_array <- new_base_array("complex") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_character_array <- new_base_array("character") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_raw_array <- new_base_array("raw") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 1 +class_list_array <- new_base_array("list") + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 2 +class_matrix <- NULL + +#' @export +#' @rdname base_arrays +#' @format NULL +#' @order 2 +class_array <- NULL + +# Defined onLoad because `new_union()` is not available at build time +on_load_define_matrix_array_classes <- function() { + class_matrix <<- new_union( + class_logical_matrix, + class_integer_matrix, + class_double_matrix, + class_complex_matrix, + class_character_matrix, + class_raw_matrix, + class_list_matrix + ) + class_array <<- new_union( + class_logical_array, + class_integer_array, + class_double_array, + class_complex_array, + class_character_array, + class_raw_array, + class_list_array + ) +} diff --git a/R/class-spec.R b/R/class-spec.R index a74c03a8..fae3d046 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -234,7 +234,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_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"), + S7_S3 = x$desc %||% paste0("S3<", paste0(x$class, collapse = "/"), ">"), ) } diff --git a/R/method-register.R b/R/method-register.R index 663013e2..9e1e1139 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -240,7 +240,15 @@ flatten_signature <- function(signature) { colnames(comb) <- NULL rows <- lapply(1:nrow(comb), function(i) comb[i, ]) - lapply(rows, function(row) Map("[[", signature, row)) + signatures <- lapply(rows, function(row) Map("[[", signature, row)) + + # Drop signatures that resolve to the same registration key. This happens + # when a union has members that share a dispatch token, e.g. the element + # types of `class_matrix` all register as "matrix". + keys <- vcapply(signatures, function(sig) { + paste0(vcapply(sig, class_register), collapse = "\r") + }) + signatures[!duplicated(keys)] } as_signature <- function(signature, generic, call = sys.call(-1L)) { diff --git a/R/property.R b/R/property.R index 6aa2e971..d8c3731f 100644 --- a/R/property.R +++ b/R/property.R @@ -250,6 +250,14 @@ prop_validate <- function(prop, value, object = NULL) { )) } + # `class_inherits()` is purely structural, so also run the class's own + # validator. This enforces constraints that aren't visible in `class()`, + # such as the element type of a `class_double_matrix`. + class_error <- class_validate(prop$class, value) + if (is.character(class_error) && length(class_error)) { + return(paste0(prop_label(object, prop$name), " ", class_error)) + } + if (is.null(validator <- prop$validator)) { return(NULL) } diff --git a/R/zzz.R b/R/zzz.R index 5b9bc2fe..7f05c480 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -148,4 +148,5 @@ methods::setOldClass(c("S7_method", "function", "S7_object")) on_load_define_or_methods() on_load_define_S7_type() on_load_define_union_classes() + on_load_define_matrix_array_classes() } diff --git a/_pkgdown.yml b/_pkgdown.yml index 121cb10a..2e380faf 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -51,6 +51,7 @@ reference: - base_classes - class_environment - base_s3_classes + - base_arrays - new_S3_class - S4_register diff --git a/man/base_arrays.Rd b/man/base_arrays.Rd new file mode 100644 index 00000000..4cb8324a --- /dev/null +++ b/man/base_arrays.Rd @@ -0,0 +1,90 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/base-array.R +\name{base_arrays} +\alias{base_arrays} +\alias{class_logical_matrix} +\alias{class_integer_matrix} +\alias{class_double_matrix} +\alias{class_complex_matrix} +\alias{class_character_matrix} +\alias{class_raw_matrix} +\alias{class_list_matrix} +\alias{class_logical_array} +\alias{class_integer_array} +\alias{class_double_array} +\alias{class_complex_array} +\alias{class_character_array} +\alias{class_raw_array} +\alias{class_list_array} +\alias{class_matrix} +\alias{class_array} +\title{S7 wrappers for matrices and arrays} +\usage{ +class_logical_matrix + +class_integer_matrix + +class_double_matrix + +class_complex_matrix + +class_character_matrix + +class_raw_matrix + +class_list_matrix + +class_logical_array + +class_integer_array + +class_double_array + +class_complex_array + +class_character_array + +class_raw_array + +class_list_array + +class_matrix + +class_array +} +\value{ +S7 classes wrapping around base matrices and arrays. +} +\description{ +S7 bundles classes for matrices and arrays. Because the element type of a +matrix or array is independent of its dimensions, there is one class for +each base vector type: +\itemize{ +\item \code{class_logical_matrix}, \code{class_integer_matrix}, \code{class_double_matrix}, +\code{class_complex_matrix}, \code{class_character_matrix}, \code{class_raw_matrix}, and +\code{class_list_matrix} for matrices. +\item \code{class_logical_array}, \code{class_integer_array}, \code{class_double_array}, +\code{class_complex_array}, \code{class_character_array}, \code{class_raw_array}, and +\code{class_list_array} for arrays. +} + +\code{class_matrix} and \code{class_array} are unions of these element-typed classes. +Like other unions (e.g. \link{class_numeric}), they can be used in \code{\link[=method]{method()}} +and \code{\link[=new_property]{new_property()}} but not as a \code{parent} in \code{\link[=new_class]{new_class()}}. To subclass a +matrix or array you must pick an element type, e.g. +\code{new_class("my_matrix", class_double_matrix)}. +} +\examples{ +# Create an S7 class that extends a double matrix +Cov <- new_class("Cov", class_double_matrix) +Cov(matrix(c(1, 0.5, 0.5, 1), nrow = 2)) + +# `class_matrix` and `class_array` dispatch on any element type +n_dim <- new_generic("n_dim", "x") +method(n_dim, class_array) <- function(x) length(dim(x)) +n_dim(Cov(diag(3))) +} +\seealso{ +\link{base_classes} and \link{base_s3_classes} for other classes that +provide compatibility with base types and S3 classes. +} diff --git a/man/base_s3_classes.Rd b/man/base_s3_classes.Rd index d3f514b5..604b24ab 100644 --- a/man/base_s3_classes.Rd +++ b/man/base_s3_classes.Rd @@ -35,4 +35,6 @@ the base packages: \item \code{class_POSIXct}, \code{class_POSIXlt} and \code{class_POSIXt} for date-times. \item \code{class_formula} for formulas. } + +Matrices and arrays are documented separately in \link{base_arrays}. } diff --git a/tests/testthat/_snaps/S3.md b/tests/testthat/_snaps/S3.md index b57ba962..f6c703a4 100644 --- a/tests/testthat/_snaps/S3.md +++ b/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 diff --git a/tests/testthat/_snaps/base.md b/tests/testthat/_snaps/base.md index 145f3f02..1c84b1d1 100644 --- a/tests/testthat/_snaps/base.md +++ b/tests/testthat/_snaps/base.md @@ -16,3 +16,34 @@ Output : +# matrix/array constructors enforce element type + + Code + Mat(1:4, nrow = 2) + Condition + Error in `Mat()`: + ! object is invalid: + - Underlying data must be not + +# class_matrix and class_array can't be a parent + + Code + new_class("Foo", parent = class_matrix) + Condition + Error in `new_class()`: + ! `parent` must be an S7 class, S3 class, or base type, not an S7 union. + Code + new_class("Foo", parent = class_array) + Condition + Error in `new_class()`: + ! `parent` must be an S7 class, S3 class, or base type, not an S7 union. + +# element-typed properties enforce element type + + Code + Foo(x = matrix(1:4, 2)) + Condition + Error in `Foo()`: + ! object properties are invalid: + - @x Underlying data must be not + diff --git a/tests/testthat/test-S3.R b/tests/testthat/test-S3.R index 49c0f2e4..0a8503ce 100644 --- a/tests/testthat/test-S3.R +++ b/tests/testthat/test-S3.R @@ -67,9 +67,11 @@ 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)) }) + # A missing tzone is valid (means local time) + expect_null(validate_POSIXct(Sys.time())) }) test_that("catches invalid data.frame", { diff --git a/tests/testthat/test-base.R b/tests/testthat/test-base.R index a25ee1f2..0218fb4e 100644 --- a/tests/testthat/test-base.R +++ b/tests/testthat/test-base.R @@ -248,25 +248,19 @@ test_that("Base S3 classes can be parents", { "All variables should have the same length." ) - # expect_no_error({ - # Foo := new_class(class_matrix) - # Foo(1:4, nrow = 2) - # Foo(NA) - # Foo(matrix(1:4, nrow = 2)) - # }) - - # expect_no_error({ - # Foo := new_class(class_array) - # - # Foo(array(1:4, dim = c(2, 2))) - # Foo(1:4, dim = c(2, 2)) - # - # Foo(array(1:24, dim = c(2, 3, 4))) - # Foo(1:24, dim = c(2, 3, 4)) - # - # Foo(array(1)) - # Foo(1) - # }) + expect_no_error({ + Foo := new_class(class_integer_matrix) + Foo(1:4, nrow = 2) + Foo(matrix(1:4, nrow = 2)) + }) + + expect_no_error({ + Foo := new_class(class_double_array) + Foo(array(1, dim = c(2, 2))) + Foo(as.double(1:4), dim = c(2, 2)) + Foo(as.double(1:24), dim = c(2, 3, 4)) + Foo(1) + }) expect_no_error({ Foo := new_class(class_formula) @@ -290,17 +284,19 @@ test_that("Base S3 classes can be properties", { }) expect_error(Foo(x = 1), "@x must be S3, not ") - # expect_no_error({ - # Foo := new_class(properties = list(x = class_matrix)) - # Foo(x = matrix()) - # }) - # expect_error(Foo(x = 1), "@x must be S3, not ") + expect_no_error({ + Foo := new_class(properties = list(x = class_double_matrix)) + Foo(x = matrix(double())) + Foo(x = matrix(as.double(1:4), 2)) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") - # expect_no_error({ - # Foo := new_class(properties = list(x = class_array)) - # Foo(x = array()) - # }) - # expect_error(Foo(x = 1), "@x must be S3, not ") + expect_no_error({ + Foo := new_class(properties = list(x = class_integer_array)) + Foo(x = array(integer())) + Foo(x = array(1:24, c(2, 3, 4))) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") expect_no_error({ Foo := new_class(properties = list(x = class_formula)) @@ -334,6 +330,43 @@ test_that("Base S3 classes can be properties", { expect_error(Foo(x = 1), "@x must be S3, not ") }) +test_that("matrix/array constructors enforce element type", { + Mat <- new_class("Mat", parent = class_double_matrix) + m <- Mat(as.double(1:4), nrow = 2) + expect_identical(dim(m), c(2L, 2L)) + expect_identical(typeof(m), "double") + expect_snapshot(error = TRUE, Mat(1:4, nrow = 2)) + + Arr <- new_class("Arr", parent = class_integer_array) + a <- Arr(1:24, dim = c(2, 3, 4)) + expect_identical(dim(a), c(2L, 3L, 4L)) + expect_identical(typeof(a), "integer") +}) + +test_that("class_matrix and class_array can't be a parent", { + expect_snapshot(error = TRUE, { + new_class("Foo", parent = class_matrix) + new_class("Foo", parent = class_array) + }) +}) + +test_that("element-typed properties enforce element type", { + Foo <- new_class("Foo", properties = list(x = class_double_matrix)) + expect_snapshot(error = TRUE, Foo(x = matrix(1:4, 2))) +}) + +test_that("can dispatch on class_matrix and class_array", { + area <- new_generic("area", "x") + method(area, class_matrix) <- function(x) "matrix" + method(area, class_array) <- function(x) "array" + + Mat <- new_class("Mat", parent = class_double_matrix) + Arr <- new_class("Arr", parent = class_integer_array) + + # A matrix is also an array, so the more specific matrix method wins + expect_equal(area(Mat(as.double(1:4), 2)), "matrix") + expect_equal(area(Arr(1:24, c(2, 3, 4))), "array") +}) test_that("ALTREP vectors aren't materialised (#607)", { skip_on_cran()