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, ): ") 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()