Nothing
library(Matrix)
source(system.file("test-tools.R", package = "Matrix"))# identical3(),
# further checkMatrix(), etc
if(interactive()) options(error = recover)
options(warn=1)# show as they happen
cat("doExtras:",doExtras,"\n")
setClass("myDGC", contains = "dgCMatrix")
(M <- new("myDGC", as(Matrix(c(-2:4, rep(0,9)), 4), "CsparseMatrix")))
stopifnot(exprs = {
M[-4L, 2L] == 2:4
MatrixClass( "myDGC") == "dgCMatrix"
MatrixClass( "dpoMatrix") == "dsyMatrix"
MatrixClass( "dppMatrix") == "dspMatrix"
MatrixClass( "corMatrix") == "dsyMatrix"
MatrixClass( "copMatrix") == "dspMatrix"
identical(MatrixClass("indMatrix"), character(0L))
identical(MatrixClass( "pMatrix"), character(0L))
})
## [matrix-Bugs][6182] Coercion method doesn't work on child class
## Bugs item #6182, at 2015-09-01 17:49 by Vitalie Spinu
setClass("A", contains = "ngCMatrix")
ngc <- as(as(as(diag(3), "CsparseMatrix"), "generalMatrix"), "nMatrix")
validObject(dd <- as(ngc, "dMatrix")) # fine
A. <- as(ngc, "A")
stopifnot(identical(as(A., "dMatrix"), dd))
## as(.) coercion failed in Matrix <= 1.2.3
stopifnot(all( abs(A.)# failed too
== diag(3)))
d <- Diagonal(3)
(dC <- as(d, "CsparseMatrix")) # "dtCMatrix" (unitriangular)
(dgC <- as(dC, "generalMatrix"))
stopifnot(exprs = {
is(dgC, "dgCMatrix") # was wrong in Matrix 1.3.2
## identical(dgC, as(dC, "dgCMatrix")) # deprecated
identical(dC , new("dtCMatrix", p = rep(0L, 4), Dim = c(3L, 3L), diag = "U"))
identical(dC , diagN2U(as(dgC, "triangularMatrix")))
})
setClass("posDef", contains = "dspMatrix")
N <- as(crossprod(M) + Diagonal(4), "packedMatrix")
(N <- new("posDef", N))
stopifnot(is(N[1:2, 1:2], "symmetricMatrix"))
#### Automatically display the class inheritance structure
#### possibly augmented with methods
allCl <- getClasses("package:Matrix")
cat("actual and virtual classes:\n")
tt <- table( isVirt <- sapply(allCl, isVirtualClass) )
names(tt) <- c('"actual"', "virtual")
tt
## The "actual" Matrix classes:
aCl <- allCl[!isVirt]
(aMcl <- aCl[grep("Matrix$", aCl)]) # length 48
aMc2 <- aCl[sapply(aCl, extends, class2 = "Matrix")]
stopifnot(all( aMcl %in% aMc2 ))
aMc2[!(aMc2 %in% aMcl)] ## only 4 : p?Cholesky & p?BunchKaufman
## Really nice would be to construct an inheritance graph and display
## it. Following things are computational variations on the theme..
## We use a version of canCoerce() that works with two *classes* instead of
## canCoerce <- function (object, Class)
classCanCoerce <- function (class1, class2)
{
extends(class1, class2) ||
!is.null(selectMethod("coerce", optional = TRUE,
signature = c(from = class1, to = class2),
useInherited = c(from = TRUE, to = FALSE)))
}
.dq <- function(ch) paste0('"', ch, '"')
.subclasses <- function(cnam) {
cd <- getClass(cnam)
unique(c(cd@className, unlist(lapply(names(cd@subclasses), .subclasses))))
}
for(n in allCl) {
if(isVirtualClass(n))
cat("Virtual class", .dq(n),"\n")
else {
cat("\"Actual\" class", .dq(n),":\n")
x <- new(n)
if(doExtras) for(m in allCl)
if(classCanCoerce(n,m)) {
ext <- extends(n, m)
if(ext) {
cat(sprintf(" extends %20s %20s \n", "", .dq(m)))
} else {
cat(sprintf(" can coerce: %20s -> %20s: ", .dq(n), .dq(m)))
tt <- try(as(x, m), silent = TRUE)
if(inherits(tt, "try-error")) {
cat("\t *ERROR* !!\n")
} else {
cat("as() ok; validObject: ")
vo <- validObject(tt, test = TRUE)
cat(if(isTRUE(vo)) "ok" else paste("OOOOOOPS:", vo), "\n")
}
}
}
cat("---\n")
}
}
cat('Time elapsed: ', proc.time(),'\n') # for the above "part I"
if(doExtras && !interactive()) { # don't want to see on source()
cat("All classes in the 'Matrix' package:\n")
for(cln in allCl) {
cat("\n-----\n\nClass", dQuote(cln),":\n ",
paste(rep("~",nchar(cln)),collapse=''),"\n")
## A smarter version would use getClass() instead of showClass(),
## build the "graph" and only then display.
##
showClass(cln)
}
cat("\n\n")
## One could extend the `display' by using (something smarter than)
## are the "coerce" methods showing more than the 'Extends' output above?
cat("All (S4) methods in the 'Matrix' package:\n")
showMethods(where="package:Matrix")
} # end{non-interactive}
## 1-indexing instead of 0-indexing for direct "dgT" should give error:
ii <- as.integer(c(1,2,2))
jj <- as.integer(c(1,1,3))
assertError(new("dgTMatrix", i=ii, j=jj, x= 10*(1:3), Dim=2:3))
assertError(new("dgTMatrix", i=ii, j=jj - 1:1, x= 10*(1:3), Dim=2:3))
assertError(new("dgTMatrix", i=ii - 1:1, j=jj, x= 10*(1:3), Dim=2:3))
(mm <- new("dgTMatrix", i=ii - 1:1, j=jj - 1:1, x= 10*(1:3), Dim=2:3))
validObject(mm)
### Sparse Logical:
m <- Matrix(c(0,0,2:0), 3,5)
mT <- as(mC <- as(m, "CsparseMatrix"), "TsparseMatrix")
stopifnot(identical(as(mT,"CsparseMatrix"), mC))
(mC. <- as(mT[1:2, 2:3], "CsparseMatrix"))
(mlC <- as(mC. , "lMatrix"))
as(mlC, "triangularMatrix")
if(!doExtras && !interactive()) q("no") ## (saving testing time)
### Test all classes: validObject(new( * )) should be fulfilled -----------
## need stoplist for now:
Rcl.struc <- c("gR", "sR", "tR")
(dR.classes <- paste0(paste0("d", Rcl.struc[Rcl.struc != "gR"]), "Matrix"))
(.R.classes <- paste0(sort(outer(c("l", "n"), Rcl.struc, paste0)), "Matrix"))
# have only stub implementation
Mat.MatFact <- c("Cholesky", "pCholesky",
"BunchKaufman", "pBunchKaufman")##, "LDL"
##FIXME maybe move to ../../MatrixModels/tests/ :
## (modmat.classes <- .subclasses("modelMatrix"))
no.t.etc <- c(.R.classes, dR.classes, Mat.MatFact)#, modmat.classes)
no.t.classes <- c(no.t.etc) # no t() available
no.norm.classes <- no.t.classes
not.Ops <- NULL # "Ops", e.g. "+" fails
not.coerce1 <- no.t.etc # not coercable from "dgeMatrix"
not.coerce2 <- no.t.etc # not coercable from "matrix"
tstMatrixClass <-
function(cl, mM = Matrix(c(2,1,1,2) + 0, 2,2,
dimnames=rep( list(c("A","B")), 2)), # dimnames: *symmetric*
mm = as(mM, "matrix"), recursive = TRUE, offset = 0)
{
## Purpose: Test 'Matrix' class {and do this for all of them}
## ----------------------------------------------------------------------
## Arguments: cl: class object of a class that extends "Matrix"
## mM: a "Matrix"-matrix which will be coerced to class 'cl'
## mm: a S3-matrix which will be coerced to class 'cl'
## ----------------------------------------------------------------------
## Author: Martin Maechler
## from pkg sfsmisc :
bl.string <- function(no) sprintf("%*s", no, "")
## Compute a few things only once :
mM <- as(as(as(mM, "unpackedMatrix"), "generalMatrix"), "dMatrix") # dge
trm <- mm; trm[lower.tri(mm)] <- 0
## not yet used:
## summList <- lapply(getGroupMembers("Summary"), get,
## envir = asNamespace("Matrix"))
if(recursive)
cList <- character(0)
extraValid <- function(m, cl = class(m)) {
sN <- slotNames(cl)
sN <- sN[sN != "factors"]
for(nm in sN)
if(!is.null(a <- attributes(slot(m, nm))))
stop(sprintf("slot '%s' with %d attributes, named: ",
nm, length(a)), paste(names(a), collapse=", "))
invisible(TRUE)
}
## This is the recursive function
dotestMat <- function(cl, offset)
{
cat. <- function(...) cat(bl.string(offset), ...)
clNam <- cl@subClass
deprecated <- grepl("^[dln](ge|tr|sy|tp|sp|[gts][CRT])Matrix$", clNam)
cat("\n==>")
cat.(clNam)
##---------
clD <- getClassDef(clNam)
if(isVirtualClass(clD)) {
cat(" - is virtual\n")
if(recursive) {
cat.("----- begin{class :", clNam, "}----new subclasses----\n")
for(ccl in clD@subclasses) {
cclN <- ccl@subClass
if(cclN %in% cList)
cat.(cclN,": see above\n")
else {
cList <<- c(cList, cclN)
dotestMat(ccl, offset = offset + 3)
}
}
cat.("----- end{class :", clNam, "}---------------------\n")
}
} else { ## --- actual class ---
genC <- extends(clD, "generalMatrix")
symC <- extends(clD, "symmetricMatrix")
triC <- extends(clD, "triangularMatrix")
diaC <- extends(clD, "diagonalMatrix")
indC <- extends(clD, "indMatrix")
if(!(genC || symC || triC || diaC || indC))
stop("does not extend one of 'general', 'symmetric', 'triangular', 'diagonal', 'ind'")
sparseC <- extends(clD, "sparseMatrix")
denseC <- extends(clD, "denseMatrix")
if(!(sparseC || denseC))
stop("does not extend either 'sparse' or 'dense'")
cat("; new(*): ")
m <- new(clNam) ; cat("ok; ")
m0 <- matrix(,0,0)
if(canCoerce(m0, clNam)) {
cat("; canCoerce(matrix(,0,0), *) => as(m0, <.>): ")
m0. <-
if(deprecated)
eval(Matrix:::.as.via.virtual(
"matrix", clNam, quote(m0)))
else as(m0, clNam)
if(.hasSlot(m, "diag") && .hasSlot(m0., "diag") &&
identical(m@diag, "N") && identical(m0.@diag, "U"))
## tolerate as(0-by-0, .) formally having unit diagonal
m0.@diag <- "N"
stopifnot(Qidentical(m, m0.)); cat("ok; ")
}
is_p <- extends(clD, "indMatrix")
is_cor <- extends(clD, "corMatrix") || extends(clD, "copMatrix")
## ^^^ has diagonal divided out
if(canCoerce(mm, clNam)) { ## replace 'm' by `non-empty' version
cat("canCoerce(mm, *) ")
m0 <- {
if(triC) trm
else if(is_p)
mm == 1 # logical *and* "true" permutation
else mm
}
if(extends(clD, "lMatrix") ||
extends(clD, "nMatrix"))
storage.mode(m0) <- "logical"
else if(extends(clD, "zMatrix"))
storage.mode(m0) <- "complex"
validObject(m) ## validity of trivial 'm' before replacing
m <-
if(deprecated)
eval(Matrix:::.as.via.virtual(
"matrix", clNam, quote(m0)))
else as(m0, clNam)
if(is_cor)
m0 <- cov2cor(m0)
} else {
m0 <- vector(Matrix:::.type.kind[Matrix:::.M.kind(m)])
dim(m0) <- c(0L,0L)
}
## m0 is the 'matrix' version of our 'Matrix' m
m. <- m0 ##m. <- if(is_p) as.integer(m0) else m0
EQ <- if(is_cor) all.equal else identical
stopifnot(EQ(m0[FALSE], m[FALSE])
, EQ(m.[TRUE], m[TRUE])
, if(length(m) >= 2) EQ(m.[2:1], m[2:1]) else TRUE)
if(all(dim(m) > 0)) { ## matrix(0,0,0)[FALSE,] is invalid too
m00 <- m[FALSE,FALSE]
m.. <- m[TRUE , TRUE]
stopifnot(dim(m00) == c(0L,0L),
dim(m..) == dim(m))
## not yet , class(m00) == clNam , identical(m.. , m)
}
cat("valid: ", validObject(m), extraValid(m, clNam),"\n")
## This can only work as long as 'm' has no NAs :
## not yet -- have version in not.Ops below
## once we have is.na():
## stopifnot(all(m == m | is.na(m))) ## check all() and "==" [Compare]
## if(any(m != m && !is.na(m)))
show(m)
## coerce to 'matrix'
m.m <- as(m, "matrix")
##=========##
checkMatrix(m, m.m,
##=========##
do.t= !(clNam %in% no.t.classes),
doNorm= !(clNam %in% no.norm.classes),
doOps = all(clNam != not.Ops),
doCoerce = all(clNam != not.coerce1),
catFUN = cat.)
### FIXME: organize differently :
### 1) produce 'mM' and 'mm' for the other cases,
### 2) use identical code for all cases
if(is(m, "dMatrix") &&
(is(m, "generalMatrix") || is(m, "symmetricMatrix"))) {
if(any(clNam == not.coerce1))
cat.("not coercable_1\n")
else if(canCoerce(mM, clNam)) {
m2 <-
if(deprecated)
eval(Matrix:::.as.via.virtual(
class(mM), clNam, quote(mM)))
else as(mM, clNam)
cat("valid:", validObject(m2), "\n")
if(!is_cor) ## as.vector()
stopifnot(as.vector(m2) == as.vector(mM))
cat.("[cr]bind2():"); mm2 <- cbind2(m2,m2)
stopifnot(dim(rbind2(m2,m2)) == 2:1 * dim(mM)); cat(" ok")
if(genC && class(mm2) == clNam) ## non-square matrix when "allowed"
m2 <- mm2
dd <- diag(m2)
cat("; `diag<-` ")
diag(m2) <- 10*dd
stopifnot(is_cor || identical(dd, diag(mM)),
identical(10*dd, diag(m2))); cat("ok ")
}
## if(all(clNam != not.coerce2)) {
if(canCoerce("matrix", clNam)) {
cat.("as(matrix, <class>): ")
m3 <-
if(deprecated)
eval(Matrix:::.as.via.virtual(
"matrix", clNam, quote(mm)))
else as(mm, clNam)
cat("valid:", validObject(m3), "\n")
} else cat.(" not coerceable from \"matrix\"\n")
## }
}
## else { ... no happens in tstMatrix() above .. }
## if(is(m, "denseMatrix")) {
## ## .........
## cat.("as dsparse* ")
## msp <- as(m, "dsparseMatrix")
## cat.("; valid coercion: ", validObject(msp), "\n")
## } else if(is(m, "sparseMatrix")) {
## } else cat.("-- not dense nor sparse -- should not happen(!?)\n")
if(is(m, "dsparseMatrix")) {
if(any(clNam == not.coerce1))
cat.("not coercable_1\n")
else {
## make sure we can coerce to dgT* -- needed, e.g. for "image"
cat.("as dgT* ")
mgT <- eval(Matrix:::.as.via.virtual(
class(m), "dgTMatrix", quote(m)))
cat(sprintf("; valid dgT* coercion: %s\n",
validObject(mgT)))
}
}
}
} # end{dotestMat}
for(scl in getClass(cl)@subclasses)
dotestMat(scl, offset + 1)
}
## in case we want to make progress:
## codetools::checkUsage(tstMatrixClass, all=TRUE)
tstMatrixClass("Matrix")
if(FALSE)## or just a sub class
tstMatrixClass("triangularMatrix")
cat('Time elapsed: ', proc.time(),'\n') # for ``statistical reasons''
if(!interactive()) warnings()
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.