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)))