The R Project SVN R

setClass("A", representation(a="numeric"))

a1 <- new("A", a=1.5)
m1 <- as.matrix(1)

setClass("M", contains = "matrix", representation(fuzz = "numeric"))

set.seed(113)
f1 <- runif(3)

stopifnot(identical(as(new("M", 1:12, nrow = 3, fuzz = f1), "matrix"),
            matrix(1:12, nrow=3)),
      identical(as(new("M", 1:12, 3, fuzz = f1), "matrix"),
            matrix(1:12, 3)),
      identical(as(new("M", 1:12, ncol = 3, fuzz = f1), "matrix"),
            matrix(1:12, ncol=3)))

setClass("B", contains = c("matrix", "A"))

stopifnot(## a new "B" element mixing two superclass objects
      identical(new("B", m1, a1)@a, a1@a),
      ## or not
      identical(as(new("B", m1),"matrix"), m1),
      ## or supplying a slot to override
      identical(new("B", matrix(m1, nrow = 2), a1, a=pi)@a, pi))

## an extra level of inheritance
setClass("C", contains = "B", representation(c = "character"))
new("C", m1, c = "Testing")

## verify that validity tests work (PR#14284)
setValidity("B", function(object) {
    if(all(is.na(object@a) | (object@a > 0)))
      TRUE
    else
      "elements of slot \"a\" must be positive"
})

a2 <- new("A", a= c(NA,3, -1, 2))

## from the SoDA package on CRAN
muststop <- function(expr, silent = TRUE) {
    tryExpr <- substitute(tryCatch(expr, error=function(cond)cond))
    value <- eval.parent(tryExpr)
    if(inherits(value, "error")) {
        if(!silent)
          message("muststop reports: ", value)
        invisible(value)
    }
    else
      stop(gettextf("The expression  %s should have thrown an error, but instead returned an object of class \"%s\"",
           deparse(substitute(expr))[[1]], class(value)))
}

muststop(new("B", m1, a2))

removeClass("B")
removeClass("C")
removeClass("M")

## TODO:  make versions of above inheriting from "array" and "ts"

removeClass("A")

## removeClass() for a union where "matrix"/"array" is part:
setClassUnion("mn", c("matrix","numeric")); removeClass("mn")# gave "node stack overflow",
setClassUnion("an", c("array", "integer")); removeClass("an")#  (ditto)
setClassUnion("AM", c("array", "matrix"));  removeClass("AM")#  (ditto)
## as had "matrix" -> "array" -> "matrix" ... recursion

## and we want this to *still* work:
stopifnot(is(tryCatch(as(a3 <- array(1:24, 2:4), "matrix"), error=function(e)e),
         "error"),
      is(as(a2 <- array(1:12, 3:4), "matrix"),
         "matrix"),
      is(a2, "matrix"), is(a2, "array"), is(a3, "array"), !is(a3, "matrix"),
      ## and yes, "for now":
      identical(a2, matrix(1:12, 3)))

## subclassing a class that did not allow new() w/o extra args failed
## through version 3.1.1
setClass("BAR", slots = c(y="integer"))

setMethod("initialize", "BAR", function(.Object, Y) {.Object@y <- Y; .Object})

setClass("BAR3", contains = "BAR")