Merge pull request #434 from RConsortium/more-classes

add some base/S3 classes

NAMESPACE

@@ -46,20 +46,28 @@ 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)
 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)

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

R/S3.R

@@ -142,19 +142,27 @@ validate_factor <- function(self) {
   c(
     if (typeof(self) != "integer")
       "Underlying data must be an <integer>",
-    if (!is.character(attr(self, "levels")))
-      "attr(, 'levels') must be a <character>"
+    if (!is.character(attr(self, "levels", TRUE)))
+      "attr(, 'levels') must be a <character>",
+    { 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"
   )
 }
 
 validate_date <- function(self) {
-  if (!is.numeric(self)) {
-    "Underlying data must be numeric"
-  }
+  c(
+    if (mode(self) != "numeric")
+      "Underlying data must be numeric",
+    if (!inherits(self, "Date"))
+      "Underlying data must have class 'Date'"
+  )
 }
 
 validate_POSIXct <- function(self) {
-  if (!is.numeric(self)) {
+  if (mode(self) != "numeric") {
     return("Underlying data must be numeric")
   }
 
@@ -164,6 +172,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 <list>")
@@ -182,23 +197,73 @@ 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")
+  if (identical(self, stats::formula(NULL, environment(self)))) # weird NULL case
+    return(invisible(NULL))
+  if (!is.call(self) || !length(self) %in% 2:3 || unclass(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
 #' @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
@@ -219,13 +284,30 @@ 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)
   },
   validator = validate_POSIXct
 )
 
+#' @export
+#' @rdname base_s3_classes
+#' @format NULL
+#' @order 3
+class_POSIXlt <- new_S3_class(c("POSIXlt", "POSIXt"),
+  constructor = function(.data = NULL, tz = "") {
+    as.POSIXlt(.data, 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
@@ -242,3 +324,45 @@ 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 = 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
+#' @order 3
+class_formula <- new_S3_class("formula",
+  constructor = function(.data = NULL, env = parent.frame()) {
+    stats::formula(.data, env = env)
+  },
+  validator = validate_formula
+)

R/S4.R

@@ -42,15 +42,14 @@ 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 (x@package == "methods") {
+      basic_classes <- S4_basic_classes()
+      if (hasName(basic_classes, x@className)) {
+        return(basic_classes[[x@className]])
+      }
+    }
     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]]
-      } else {
-        x
-      }
     } else {
       x
     }
@@ -63,7 +62,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 +76,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 +120,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)

R/base.R

@@ -34,6 +34,8 @@ base_default <- function(type) {
     raw = raw(),
     list = list(),
     expression = expression(),
+    name = quote(quote(x)),
+    call = quote(quote({})),
 
     `function` = quote(function() {}),
     environment = quote(new.env(parent = emptyenv()))
@@ -68,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)
 #'
@@ -79,6 +83,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 +143,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 +185,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)
 }

R/class-spec.R

@@ -282,6 +282,7 @@ base_class <- function(x) {
     special = "function",
     builtin = "function",
     language = "call",
+    symbol = "name",
     typeof(x)
   )
 }