From e451a87ad12e65d2b4e80de7d36d94a37a85cae1 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 1 Sep 2024 05:55:26 -0700 Subject: [PATCH 01/17] add base/S3 classes for name, call, language, POSIXt, POSIXlt, matrix, array and formula --- NAMESPACE | 8 +++ R/S3.R | 109 ++++++++++++++++++++++++++++++++++++++++- R/base.R | 22 +++++++++ R/class-spec.R | 1 + man/base_classes.Rd | 13 +++++ man/base_s3_classes.Rd | 23 ++++++++- 6 files changed, 172 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index f2e43419..b15bfcee 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -46,8 +46,12 @@ export(as_class) export(check_is_S7) export(class_Date) 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_complex) export(class_data.frame) @@ -55,11 +59,15 @@ export(class_double) export(class_environment) export(class_expression) export(class_factor) +export(class_formula) export(class_function) export(class_integer) +export(class_language) export(class_list) export(class_logical) +export(class_matrix) export(class_missing) +export(class_name) export(class_numeric) export(class_raw) export(class_vector) diff --git a/R/S3.R b/R/S3.R index dcfbe0ff..7cc51330 100644 --- a/R/S3.R +++ b/R/S3.R @@ -163,6 +163,13 @@ validate_POSIXct <- function(self) { } } +validate_POSIXlt <- function(self) { + tryCatch({ + format(self) # calls valid_POSIXlt() in C + invisible(NULL) + }, error = function(e) conditionMessage(e)) +} + validate_data.frame <- function(self) { if (!is.list(self)) { return("Underlying data must be a ") @@ -181,16 +188,64 @@ 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 + return(invisible(NULL)) + if (!is.integer(dim(self)) || length(dim(self)) != 2L || !all(dim(self) > 0L)) + return("dim(self) must be a non-negative integer vector of length 2") + if (!valid_dimnames(self)) + return("dimnames(self) must be NULL or a length 2 list of either NULL or a character vector of length equal to its corresponding dimension") + "is.matrix(self) is FALSE" +} + +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") + if (identical(self, stats::formula(NULL, environment(self)))) # weird NULL case + return(invisible(NULL)) + if (!is.call(self) || !length(self) %in% 2:3 || self[[1L]] != quote(`~`)) + return("must be a call to `~` of length 2 or 3") +} + #' S7 wrappers for key S3 classes #' #' @description #' S7 bundles [S3 definitions][new_S3_class] for key S3 classes provided by -#' the base package: +#' the base packages: #' #' * `class_data.frame` for data frames. #' * `class_Date` for dates. #' * `class_factor` for factors. -#' * `class_POSIXct` for `POSIXct` date-times. +#' * `class_POSIXct`, `class_POSIXlt` and `class_POSIXt` for date-times. +#' * `class_matrix` for matrices. +#' * `class_array` for arrays. +#' * `class_formula` for formulas. + #' #' @export #' @name base_s3_classes @@ -225,6 +280,23 @@ class_POSIXct <- new_S3_class("POSIXct", validator = validate_POSIXct ) +#' @export +#' @rdname base_s3_classes +#' @format NULL +#' @order 3 +class_POSIXlt <- new_S3_class("POSIXlt", + constructor = function(.data = NULL, tz = "") { + as.POSIXlt(NULL, tz = tz) + }, + validator = validate_POSIXlt +) + +#' @export +#' @rdname base_s3_classes +#' @format NULL +#' @order 3 +class_POSIXt <- new_S3_class("POSIXt") # abstract class + #' @export #' @rdname base_s3_classes #' @format NULL @@ -241,3 +313,36 @@ class_data.frame <- new_S3_class("data.frame", }, validator = validate_data.frame ) + +#' @export +#' @rdname base_s3_classes +#' @format NULL +#' @order 3 +class_matrix <- new_S3_class("matrix", + constructor = function(.data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL) { + 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 = NA, dim = length(data), dimnames = NULL) { + array(.data, dim, dimnames) + }, + validator = validate_array +) + +#' @export +#' @rdname base_s3_classes +#' @format NULL +#' @order 3 +class_formula <- new_S3_class("formula", + constructor = function(.data = NULL, env = parent.frame()) { + stats::formula(.data, env) + }, + validator = validate_formula +) diff --git a/R/base.R b/R/base.R index 753da654..10165f43 100644 --- a/R/base.R +++ b/R/base.R @@ -34,6 +34,8 @@ base_default <- function(type) { raw = raw(), list = list(), expression = expression(), + name = alist(x=)$x, + call = call("{"), `function` = function() {}, environment = new.env(parent = emptyenv()) @@ -79,6 +81,7 @@ str.S7_base_class <- function(object, ..., nest.lev = 0) { #' `class_complex`, `class_character`, and `class_raw`. #' * `class_vector` is a union of `class_atomic`, `class_list`, and #' `class_expression`. +#' * `class_language` is a union of `class_name` and `class_call`. #' #' @order 0 #' @name base_classes @@ -138,6 +141,18 @@ class_list <- new_base_class("list") #' @order 1 class_expression <- new_base_class("expression") +#' @export +#' @rdname base_classes +#' @format NULL +#' @order 1 +class_name <- new_base_class("name") + +#' @export +#' @rdname base_classes +#' @format NULL +#' @order 1 +class_call <- new_base_class("call") + #' @export #' @rdname base_classes #' @format NULL @@ -168,9 +183,16 @@ class_atomic <- NULL #' @order 2 class_vector <- NULL +#' @export +#' @rdname base_classes +#' @format NULL +#' @order 2 +class_language <- NULL + # Define onload to avoid dependencies between files on_load_define_union_classes <- function() { class_numeric <<- new_union(class_integer, class_double) class_atomic <<- new_union(class_logical, class_numeric, class_complex, class_character, class_raw) class_vector <<- new_union(class_atomic, class_expression, class_list) + class_language <<- new_union(class_name, class_call) } diff --git a/R/class-spec.R b/R/class-spec.R index 525766f6..da9bfc82 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -228,6 +228,7 @@ base_class <- function(x) { special = "function", builtin = "function", language = "call", + symbol = "name", typeof(x) ) } diff --git a/man/base_classes.Rd b/man/base_classes.Rd index 6411af27..1dc91535 100644 --- a/man/base_classes.Rd +++ b/man/base_classes.Rd @@ -11,11 +11,14 @@ \alias{class_raw} \alias{class_list} \alias{class_expression} +\alias{class_name} +\alias{class_call} \alias{class_function} \alias{class_environment} \alias{class_numeric} \alias{class_atomic} \alias{class_vector} +\alias{class_language} \title{S7 wrappers for base types} \usage{ class_logical @@ -34,6 +37,10 @@ class_list class_expression +class_name + +class_call + class_function class_environment @@ -43,6 +50,8 @@ class_numeric class_atomic class_vector + +class_language } \value{ S7 classes wrapping around common base types and S3 classes. @@ -59,8 +68,11 @@ within S7: \item \code{class_raw} \item \code{class_list} \item \code{class_expression} +\item \code{class_name} +\item \code{class_call} \item \code{class_function} \item \code{class_environment} (can only be used for properties) +\item \code{class_language} } We also include three union types to model numerics, atomics, and vectors @@ -71,6 +83,7 @@ respectively: \code{class_complex}, \code{class_character}, and \code{class_raw}. \item \code{class_vector} is a union of \code{class_atomic}, \code{class_list}, and \code{class_expression}. +\item \code{class_language} is a union of \code{class_name} and \code{class_call}. } } \examples{ diff --git a/man/base_s3_classes.Rd b/man/base_s3_classes.Rd index efd2ab93..e98ed8fc 100644 --- a/man/base_s3_classes.Rd +++ b/man/base_s3_classes.Rd @@ -6,7 +6,13 @@ \alias{class_factor} \alias{class_Date} \alias{class_POSIXct} +\alias{class_POSIXlt} +\alias{class_POSIXt} \alias{class_data.frame} +\alias{class_matrix} +\alias{class_array} +\alias{class_formula} + \title{S7 wrappers for key S3 classes} \usage{ class_factor @@ -15,16 +21,29 @@ class_Date class_POSIXct +class_POSIXlt + +class_POSIXt + class_data.frame + +class_matrix + +class_array + +class_formula } \description{ S7 bundles \link[=new_S3_class]{S3 definitions} for key S3 classes provided by -the base package: +the base packages: \itemize{ \item \code{class_data.frame} for data frames. \item \code{class_Date} for dates. \item \code{class_factor} for factors. -\item \code{class_POSIXct} for \code{POSIXct} date-times. +\item \code{class_POSIXct}, \code{class_POSIXlt} and \code{class_POSIXt} for date-times. +\item \code{class_matrix} for matrices. +\item \code{class_array} for arrays. +\item \code{class_formula} for formulas. } } \keyword{datasets} From 3f2e9be956e1bf9075e02e8a3a4600e86f26393e Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 8 Sep 2024 09:14:28 -0700 Subject: [PATCH 02/17] allow dimensions of zero length on arrays and matrices --- R/S3.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/S3.R b/R/S3.R index 7cc51330..bc18f99f 100644 --- a/R/S3.R +++ b/R/S3.R @@ -206,7 +206,7 @@ valid_dimnames <- function(self) { validate_matrix <- function(self) { if (is.matrix(self)) # is.matrix() methods should only return TRUE if valid return(invisible(NULL)) - if (!is.integer(dim(self)) || length(dim(self)) != 2L || !all(dim(self) > 0L)) + if (!is.integer(dim(self)) || length(dim(self)) != 2L || !all(dim(self) >= 0L)) return("dim(self) must be a non-negative integer vector of length 2") if (!valid_dimnames(self)) return("dimnames(self) must be NULL or a length 2 list of either NULL or a character vector of length equal to its corresponding dimension") @@ -216,7 +216,7 @@ validate_matrix <- function(self) { 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)) + 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") From fcf43e29ade858933699e0fdd33a06a9e9ce6afd Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 9 Sep 2024 03:31:39 -0700 Subject: [PATCH 03/17] POSIXct and POSIXlt inherit from POSIXt --- R/S3.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/S3.R b/R/S3.R index bc18f99f..8b12d3ca 100644 --- a/R/S3.R +++ b/R/S3.R @@ -273,7 +273,7 @@ class_Date <- new_S3_class("Date", #' @rdname base_s3_classes #' @format NULL #' @order 3 -class_POSIXct <- new_S3_class("POSIXct", +class_POSIXct <- new_S3_class(c("POSIXct", "POSIXt"), constructor = function(.data = double(), tz = "") { .POSIXct(.data, tz = tz) }, @@ -284,7 +284,7 @@ class_POSIXct <- new_S3_class("POSIXct", #' @rdname base_s3_classes #' @format NULL #' @order 3 -class_POSIXlt <- new_S3_class("POSIXlt", +class_POSIXlt <- new_S3_class(c("POSIXlt", "POSIXt"), constructor = function(.data = NULL, tz = "") { as.POSIXlt(NULL, tz = tz) }, From 46259fcd157b595b59ed80e300877f83039be57f Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 14 Sep 2024 14:18:37 -0700 Subject: [PATCH 04/17] use quote(x) as default for class_name, as the missing symbol was too problematic in practice --- R/base.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/base.R b/R/base.R index 10165f43..684ed987 100644 --- a/R/base.R +++ b/R/base.R @@ -34,7 +34,7 @@ base_default <- function(type) { raw = raw(), list = list(), expression = expression(), - name = alist(x=)$x, + name = quote(quote(x)), call = call("{"), `function` = function() {}, From c466db5c5fddcbfcd399716ce33bd1a85a8ed005 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 21 Sep 2024 11:58:51 -0700 Subject: [PATCH 05/17] Add mappings for name, call and all of the basic S3 types to S4_base_classes(), which is renamed to S4_basic_classes() for consistency with S4's terminology. Looking up S3 classes required a slight change to S4_to_S7_class() and the corresponding test. It is worth recognizing that this mechanism is now a general mapping from `class(x)[1]` to the corresponding `class_` object and could be used to implement a class_for_name() and even class_for_object(). --- R/S4.R | 29 ++++++++++++++++++++--------- tests/testthat/test-S4.R | 2 +- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/R/S4.R b/R/S4.R index 0e901694..b033aa69 100644 --- a/R/S4.R +++ b/R/S4.R @@ -42,15 +42,15 @@ S4_to_S7_class <- function(x, error_base = "") { subclasses <- lapply(subclasses, function(x) methods::getClass(x@subClass)) do.call("new_union", subclasses) } else if (methods::is(x, "classRepresentation")) { - if (methods::extends(x, "oldClass")) { - new_S3_class(as.character(x@className)) - } else if (x@package == "methods") { - base_classes <- S4_base_classes() - if (hasName(base_classes, x@className)) { - base_classes[[x@className]] + if (x@package == "methods") { + basic_classes <- S4_basic_classes() + if (hasName(basic_classes, x@className)) { + basic_classes[[x@className]] } else { x } + } else if (methods::extends(x, "oldClass")) { + new_S3_class(as.character(x@className)) } else { x } @@ -63,7 +63,7 @@ S4_to_S7_class <- function(x, error_base = "") { } } -S4_base_classes <- function() { +S4_basic_classes <- function() { list( NULL = NULL, logical = class_logical, @@ -77,7 +77,18 @@ S4_base_classes <- function() { expression = class_expression, vector = class_vector, `function` = class_function, - environment = class_environment + environment = class_environment, + name = class_name, + call = class_call, + data.frame = class_data.frame, + Date = class_Date, + factor = class_factor, + POSIXct = class_POSIXct, + POSIXlt = class_POSIXlt, + POSIXt = class_POSIXt, + matrix = class_matrix, + array = class_array, + formula = class_formula ) } @@ -110,7 +121,7 @@ S4_class_name <- function(x) { class <- x@className package <- x@package %||% attr(class, "package") - if (identical(package, "methods") && class %in% names(S4_base_classes())) { + if (identical(package, "methods") && class %in% names(S4_basic_classes())) { class } else if (is.null(package) || identical(package, ".GlobalEnv")) { paste0("S4/", class) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index ecd18b0c..0a615eda 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -30,7 +30,7 @@ test_that("converts S4 unions to S7 unions", { }) test_that("converts S4 representation of S3 classes to S7 representation", { - expect_equal(S4_to_S7_class(getClass("Date")), new_S3_class("Date"), ignore_function_env = TRUE) + expect_equal(S4_to_S7_class(getClass("Date")), class_Date, ignore_function_env = TRUE) }) test_that("errors on non-S4 classes", { From b35e2f083b3091b65dbf0478e3f320e706953ac6 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 21 Sep 2024 18:22:19 -0700 Subject: [PATCH 06/17] S4_to_S7_class() returns new_S3_class()es for oldClasses defined in methods that lack a corresponding `class_` object. --- R/S4.R | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/R/S4.R b/R/S4.R index b033aa69..2b777494 100644 --- a/R/S4.R +++ b/R/S4.R @@ -45,11 +45,10 @@ S4_to_S7_class <- function(x, error_base = "") { if (x@package == "methods") { basic_classes <- S4_basic_classes() if (hasName(basic_classes, x@className)) { - basic_classes[[x@className]] - } else { - x + return(basic_classes[[x@className]]) } - } else if (methods::extends(x, "oldClass")) { + } + if (methods::extends(x, "oldClass")) { new_S3_class(as.character(x@className)) } else { x From ac419f141bfc7a62c53ea6622e88ef28c77e444b Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 22 Sep 2024 09:26:45 -0700 Subject: [PATCH 07/17] nrow= defaults to length(.data) for matrix construction for convenience and consistency with matrix() behavior --- R/S3.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/S3.R b/R/S3.R index 8b12d3ca..c79b94ce 100644 --- a/R/S3.R +++ b/R/S3.R @@ -319,7 +319,7 @@ class_data.frame <- new_S3_class("data.frame", #' @format NULL #' @order 3 class_matrix <- new_S3_class("matrix", - constructor = function(.data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL) { + constructor = function(.data = NA, nrow = length(.data), ncol = 1, byrow = FALSE, dimnames = NULL) { matrix(.data, nrow, ncol, byrow, dimnames) }, validator = validate_matrix From c0819ad052410b977c4c873fdf6cb60a4dfeb96c Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Oct 2024 12:34:02 -0400 Subject: [PATCH 08/17] Update R/S3.R Co-authored-by: Hadley Wickham --- R/S3.R | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/R/S3.R b/R/S3.R index 6aa69165..18a944d4 100644 --- a/R/S3.R +++ b/R/S3.R @@ -205,13 +205,14 @@ valid_dimnames <- function(self) { } validate_matrix <- function(self) { - if (is.matrix(self)) # is.matrix() methods should only return TRUE if valid - return(invisible(NULL)) - if (!is.integer(dim(self)) || length(dim(self)) != 2L || !all(dim(self) >= 0L)) - return("dim(self) must be a non-negative integer vector of length 2") - if (!valid_dimnames(self)) - return("dimnames(self) must be NULL or a length 2 list of either NULL or a character vector of length equal to its corresponding dimension") - "is.matrix(self) is FALSE" + 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) { From ebfceb969484e7b1e671556c20c58fc2827631fb Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Oct 2024 12:34:27 -0400 Subject: [PATCH 09/17] Add tests for base and base-S3 classes --- tests/testthat/helper.R | 18 +++ tests/testthat/test-base.R | 314 +++++++++++++++++++++++++++++++++++++ 2 files changed, 332 insertions(+) diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 45061f8a..7de3fc3e 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -69,3 +69,21 @@ named_list <- function(...) { names(x) <- names2(x) x } + +`:=` <- function(sym, val) { + cl <- sys.call() + cl[[1L]] <- quote(`<-`) + stopifnot(is.symbol(cl[[2L]]) && is.call(cl[[3L]])) + cl[[3L]]$name <- as.character(cl[[2L]]) + eval.parent(cl) +} + +`append1<-` <- function (x, value) { + stopifnot(is.list(x) || identical(mode(x), mode(value))) + x[[length(x) + 1L]] <- value + x +} + +`append<-` <- `c` + +`add<-` <- `+` diff --git a/tests/testthat/test-base.R b/tests/testthat/test-base.R index 359efc2e..391a6e5a 100644 --- a/tests/testthat/test-base.R +++ b/tests/testthat/test-base.R @@ -23,3 +23,317 @@ test_that("classes can inherit from base types", { expect_error(foo(), NA) } }) + + +test_that("Base classes can be a parent class", { + + expect_no_error({ + Foo := new_class(class_logical) + Foo() + Foo(TRUE) + }) + expect_error(Foo(1), "must be not ") + + expect_no_error({ + Foo := new_class(class_integer) + Foo() + Foo(1L) + }) + expect_error(Foo(1), "must be not ") + + expect_no_error({ + Foo := new_class(class_double) + Foo() + Foo(1) + }) + expect_error(Foo(1L), "must be not ") + + expect_no_error({ + Foo := new_class(class_complex) + Foo() + Foo(1 + 1i) + }) + expect_error(Foo(1), "must be not ") + + expect_no_error({ + Foo := new_class(class_character) + Foo() + Foo("a") + }) + expect_error(Foo(1), "must be not ") + + expect_no_error({ + Foo := new_class(class_raw) + Foo() + Foo(charToRaw("a")) + }) + expect_error(Foo(1), "must be not ") + + expect_no_error({ + Foo := new_class(class_list) + Foo() + Foo(list()) + }) + expect_error(Foo(1), "must be not ") + + expect_no_error({ + Foo := new_class(class_expression) + Foo() + Foo(expression(1)) + }) + expect_error(Foo(1), "must be not ") + + expect_no_error({ + Foo := new_class(class_call) + Foo() + Foo(quote(a())) + }) + expect_error(Foo(1), "must be not ") + + expect_no_error({ + Foo := new_class(class_function) + Foo() + Foo(identity) + }) + expect_error(Foo(1), "must be not ") + + # union types cannot be a parent: + # + # class_numeric + # class_atomic + # class_vector + # class_language + + # class_name cannot be a parent because: + # 'Error: cannot set attribute on a symbol' + + # class_environment cannot currently be a parent + # (this is expected to change in the future) + +}) + + +test_that("All base classes can be a property class", { + expect_no_error({ + Foo := new_class(properties = list(x = class_logical)) + Foo(x = TRUE) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_integer)) + Foo(x = 1L) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_double)) + Foo(x = 1) + }) + expect_error(Foo(x = 1L), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_complex)) + Foo(x = 1 + 1i) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_character)) + Foo(x = "a") + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_raw)) + Foo(x = charToRaw("a")) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_list)) + Foo(x = list()) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_expression)) + Foo(x = expression(1)) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_call)) + Foo(x = quote(a())) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_function)) + Foo(x = identity) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_name)) + Foo(x = quote(a)) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_environment)) + Foo(x = new.env()) + }) + expect_error(Foo(x = 1), "@x must be , not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_atomic)) + Foo(x = 1) + }) + expect_error(Foo(x = list(TRUE)), "@x must be .*, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_vector)) + Foo(x = 1) + }) + expect_error(Foo(x = quote(x)), "@x must be .*, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_language)) + Foo(x = quote(a())) + }) + expect_error(Foo(x = 1), "@x must be .*, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_numeric)) + Foo(x = 1) + }) + expect_error(Foo(x = TRUE), "@x must be .*, not ") + +}) + + +test_that("Base S3 classes can be parents", { + + expect_no_error({ + Foo := new_class(class_factor) + Foo() + Foo(1L, levels = letters[1:3]) + }) + + expect_no_error({ + Foo := new_class(class_Date) + Foo() + Foo(Sys.Date()) + Foo(rep(Sys.Date(), 3)) + Foo(1) + }) + expect_error(Foo("a"), "Underlying data must be numeric") + + expect_no_error({ + Foo := new_class(class_POSIXct) + Foo() + Foo(Sys.time()) + Foo(rep(Sys.time(), 3)) + Foo(1) + }) + expect_error(Foo("a"), "Underlying data must be numeric") + + expect_no_error({ + Foo := new_class(class_data.frame) + Foo() + Foo(data.frame(x = 1)) + Foo(list(x = 1)) + Foo(list(x = 1), "rowname") + }) + expect_error(Foo(list(x = 1:3, y = 1:4)), + "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_formula) + Foo(~ x) + Foo("~ x") + Foo(call("~", 1, 2)) + Foo(quote(~x)) + }) + +}) + +test_that("Base S3 classes can be properties", { + + expect_no_error({ + Foo := new_class(properties = list(x = class_factor)) + Foo(x = factor()) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_data.frame)) + Foo(x = data.frame()) + }) + 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_array)) + Foo(x = array()) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_formula)) + Foo(x = ~ x) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_Date)) + Foo(x = Sys.Date()) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_POSIXct)) + Foo(x = Sys.time()) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_POSIXlt)) + Foo(x = as.POSIXlt(Sys.time())) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") + + expect_no_error({ + Foo := new_class(properties = list(x = class_POSIXt)) + Foo(x = Sys.time()) + Foo(x = as.POSIXlt(Sys.time())) + }) + expect_error(Foo(x = 1), "@x must be S3, not ") + +}) From 5a9905cfc58f75d83cc69e1ab04433a237923ed6 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Oct 2024 12:37:54 -0400 Subject: [PATCH 10/17] changes to make tests pass --- R/S3.R | 21 +++++++++++++-------- R/base.R | 2 +- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/R/S3.R b/R/S3.R index 18a944d4..0f376e1d 100644 --- a/R/S3.R +++ b/R/S3.R @@ -148,13 +148,11 @@ validate_factor <- function(self) { } validate_date <- function(self) { - if (!is.numeric(self)) { - "Underlying data must be numeric" - } + if (mode(self) != "numeric") } validate_POSIXct <- function(self) { - if (!is.numeric(self)) { + if (mode(self) != "numeric") { return("Underlying data must be numeric") } @@ -230,7 +228,7 @@ validate_formula <- function(self) { return("environment(self) must be non-NULL") if (identical(self, stats::formula(NULL, environment(self)))) # weird NULL case return(invisible(NULL)) - if (!is.call(self) || !length(self) %in% 2:3 || self[[1L]] != quote(`~`)) + if (!is.call(self) || !length(self) %in% 2:3 || unclass(self)[[1L]] != quote(`~`)) return("must be a call to `~` of length 2 or 3") } @@ -288,7 +286,7 @@ class_POSIXct <- new_S3_class(c("POSIXct", "POSIXt"), #' @order 3 class_POSIXlt <- new_S3_class(c("POSIXlt", "POSIXt"), constructor = function(.data = NULL, tz = "") { - as.POSIXlt(NULL, tz = tz) + as.POSIXlt(.data, tz = tz) }, validator = validate_POSIXlt ) @@ -321,7 +319,14 @@ class_data.frame <- new_S3_class("data.frame", #' @format NULL #' @order 3 class_matrix <- new_S3_class("matrix", - constructor = function(.data = NA, nrow = length(.data), ncol = 1, byrow = FALSE, dimnames = NULL) { + 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 @@ -332,7 +337,7 @@ class_matrix <- new_S3_class("matrix", #' @format NULL #' @order 3 class_array <- new_S3_class("array", - constructor = function(.data = NA, dim = length(data), dimnames = NULL) { + constructor = function(.data = logical(), dim = base::dim(.data) %||% length(.data), dimnames = base::dimnames(.data)) { array(.data, dim, dimnames) }, validator = validate_array diff --git a/R/base.R b/R/base.R index c74f3c57..ec7ccdaa 100644 --- a/R/base.R +++ b/R/base.R @@ -35,7 +35,7 @@ base_default <- function(type) { list = list(), expression = expression(), name = quote(quote(x)), - call = call("{"), + call = quote(quote({})), `function` = quote(function() {}), environment = quote(new.env(parent = emptyenv())) From 223074e8fb1d36ae5c0dcea14bb12f5106eac66e Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Oct 2024 12:38:09 -0400 Subject: [PATCH 11/17] redocument --- R/base.R | 2 ++ man/base_classes.Rd | 1 - man/base_s3_classes.Rd | 1 - 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/base.R b/R/base.R index ec7ccdaa..9e377c02 100644 --- a/R/base.R +++ b/R/base.R @@ -70,6 +70,8 @@ str.S7_base_class <- function(object, ..., nest.lev = 0) { #' * `class_raw` #' * `class_list` #' * `class_expression` +#' * `class_name` +#' * `class_call` #' * `class_function` #' * `class_environment` (can only be used for properties) #' diff --git a/man/base_classes.Rd b/man/base_classes.Rd index 1dc91535..9611bfbc 100644 --- a/man/base_classes.Rd +++ b/man/base_classes.Rd @@ -72,7 +72,6 @@ within S7: \item \code{class_call} \item \code{class_function} \item \code{class_environment} (can only be used for properties) -\item \code{class_language} } We also include three union types to model numerics, atomics, and vectors diff --git a/man/base_s3_classes.Rd b/man/base_s3_classes.Rd index e98ed8fc..bf501523 100644 --- a/man/base_s3_classes.Rd +++ b/man/base_s3_classes.Rd @@ -12,7 +12,6 @@ \alias{class_matrix} \alias{class_array} \alias{class_formula} - \title{S7 wrappers for key S3 classes} \usage{ class_factor From d6a4eae9a43a43f160c4b9636986b61dc4d369ea Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Oct 2024 12:38:58 -0400 Subject: [PATCH 12/17] show `dim` in `print()` --- R/class.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/class.R b/R/class.R index 281b8e24..5df9244c 100644 --- a/R/class.R +++ b/R/class.R @@ -301,7 +301,7 @@ str.S7_object <- function(object, ..., nest.lev = 0) { if (is.environment(object)) { attributes(object) <- NULL } else { - attributes(object) <- list(names = names(object)) + attributes(object) <- list(names = names(object), dim = dim(object)) } str(object, nest.lev = nest.lev) From bf3e7f3e4ea228cff2455bdcbb1d598688c05c53 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Oct 2024 12:40:14 -0400 Subject: [PATCH 13/17] additional tweaks --- R/S3.R | 13 ++++++++++--- R/class.R | 7 ++++--- tests/testthat/_snaps/S3.md | 3 ++- 3 files changed, 16 insertions(+), 7 deletions(-) diff --git a/R/S3.R b/R/S3.R index 0f376e1d..c81f61e4 100644 --- a/R/S3.R +++ b/R/S3.R @@ -142,13 +142,20 @@ validate_factor <- function(self) { c( if (typeof(self) != "integer") "Underlying data must be an ", - if (!is.character(attr(self, "levels"))) - "attr(, 'levels') must be a " + if (!is.character(attr(self, "levels", TRUE))) + "attr(, 'levels') must be a ", + if (max(unclass(self), 0L) > length(attr(self, "levels", TRUE))) + "Not enough 'levels' for underlying data" ) } validate_date <- function(self) { + c( if (mode(self) != "numeric") + "Underlying data must be numeric", + if (!inherits(self, "Date")) + "Underlying data must have class 'Date'" + ) } validate_POSIXct <- function(self) { @@ -349,7 +356,7 @@ class_array <- new_S3_class("array", #' @order 3 class_formula <- new_S3_class("formula", constructor = function(.data = NULL, env = parent.frame()) { - stats::formula(.data, env) + stats::formula(.data, env = env) }, validator = validate_formula ) diff --git a/R/class.R b/R/class.R index 5df9244c..53737cdb 100644 --- a/R/class.R +++ b/R/class.R @@ -252,6 +252,10 @@ new_object <- function(.parent, ...) { stop(msg) } + # force .parent before ... + # TODO: Some type checking on `.parent`? + object <- .parent + args <- list(...) if ("" %in% names2(args)) { stop("All arguments to `...` must be named") @@ -259,9 +263,6 @@ new_object <- function(.parent, ...) { has_setter <- vlapply(class@properties[names(args)], prop_has_setter) - # TODO: Some type checking on `.parent`? - object <- .parent - attrs <- c( list(class = class_dispatch(class), S7_class = class), args[!has_setter], diff --git a/tests/testthat/_snaps/S3.md b/tests/testthat/_snaps/S3.md index 31caf801..38231eab 100644 --- a/tests/testthat/_snaps/S3.md +++ b/tests/testthat/_snaps/S3.md @@ -56,7 +56,8 @@ Code validate_date("x") Output - [1] "Underlying data must be numeric" + [1] "Underlying data must be numeric" + [2] "Underlying data must have class 'Date'" # catches invalid POSIXct From 68c0de255196cb32c2594712d2c0f02932df81f4 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Oct 2024 12:48:24 -0400 Subject: [PATCH 14/17] Accept a `factor` in `class_factor()` constructor. --- R/S3.R | 7 +++++-- tests/testthat/test-base.R | 1 + 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/R/S3.R b/R/S3.R index c81f61e4..f7468cc2 100644 --- a/R/S3.R +++ b/R/S3.R @@ -259,7 +259,8 @@ validate_formula <- function(self) { #' @format NULL #' @order 3 class_factor <- new_S3_class("factor", - constructor = function(.data = integer(), levels = character()) { + constructor = function(.data = integer(), levels = NULL) { + levels <- levels %||% attr(.data, "levels", TRUE) %||% character() structure(.data, levels = levels, class = "factor") }, validator = validate_factor @@ -344,7 +345,9 @@ class_matrix <- new_S3_class("matrix", #' @format NULL #' @order 3 class_array <- new_S3_class("array", - constructor = function(.data = logical(), dim = base::dim(.data) %||% length(.data), dimnames = base::dimnames(.data)) { + constructor = function(.data = logical(), + dim = base::dim(.data) %||% length(.data), + dimnames = base::dimnames(.data)) { array(.data, dim, dimnames) }, validator = validate_array diff --git a/tests/testthat/test-base.R b/tests/testthat/test-base.R index 391a6e5a..ba62cc24 100644 --- a/tests/testthat/test-base.R +++ b/tests/testthat/test-base.R @@ -219,6 +219,7 @@ test_that("Base S3 classes can be parents", { Foo := new_class(class_factor) Foo() Foo(1L, levels = letters[1:3]) + Foo(factor(letters[1:3])) }) expect_no_error({ From 99407ca3c6f9b455e06e609fee8f44dc0140b37f Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 2 Oct 2024 12:49:37 -0400 Subject: [PATCH 15/17] update test snapshots --- tests/testthat/_snaps/S3.md | 5 +++-- tests/testthat/_snaps/constructor.md | 5 ++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/testthat/_snaps/S3.md b/tests/testthat/_snaps/S3.md index 38231eab..01f69700 100644 --- a/tests/testthat/_snaps/S3.md +++ b/tests/testthat/_snaps/S3.md @@ -48,8 +48,9 @@ Code validate_factor(structure("x")) Output - [1] "Underlying data must be an " - [2] "attr(, 'levels') must be a " + [1] "Underlying data must be an " + [2] "attr(, 'levels') must be a " + [3] "Not enough 'levels' for underlying data" # catches invalid dates diff --git a/tests/testthat/_snaps/constructor.md b/tests/testthat/_snaps/constructor.md index a86c4857..dc728506 100644 --- a/tests/testthat/_snaps/constructor.md +++ b/tests/testthat/_snaps/constructor.md @@ -38,14 +38,13 @@ Code new_constructor(class_factor, list()) Output - function (.data = integer(), levels = character()) + function (.data = integer(), levels = NULL) new_object(new_factor(.data = .data, levels = levels)) Code new_constructor(class_factor, as_properties(list(x = class_numeric, y = class_numeric))) Output - function (.data = integer(), levels = character(), x = integer(0), - y = integer(0)) + function (.data = integer(), levels = NULL, x = integer(0), y = integer(0)) new_object(new_factor(.data = .data, levels = levels), x = x, y = y) From b3bd5ad93ddcc349afb64384df5334ebb744376f Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 7 Oct 2024 08:51:49 -0400 Subject: [PATCH 16/17] Validate factors all positive --- R/S3.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/S3.R b/R/S3.R index f7468cc2..76e86608 100644 --- a/R/S3.R +++ b/R/S3.R @@ -144,7 +144,10 @@ validate_factor <- function(self) { "Underlying data must be an ", if (!is.character(attr(self, "levels", TRUE))) "attr(, 'levels') must be a ", - if (max(unclass(self), 0L) > length(attr(self, "levels", TRUE))) + { rng <- range(0L, unclass(self)); NULL }, + if (rng[1] < 0L) + "Underlying data must be all positive", + if (rng[2] > length(attr(self, "levels", TRUE))) "Not enough 'levels' for underlying data" ) } From 838e258c24ce1682d04b7f2a6329ece3194cbfd7 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 7 Oct 2024 08:57:01 -0400 Subject: [PATCH 17/17] add NEWS --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index 31ecac69..748cee2a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # S7 (development version) +* Added support for more base/S3 classes (#434): + `class_POSIXlt`, `class_POSIXt`, `class_matrix`, `class_array`, + `class_formula`, `class_call`, `class_language`, `class_name` + * Fixed S3 methods registration across packages (#422). * `convert()` now provides a default method to transform a parent class instance