### Simple fallback methods for all dense matrices ### These are "cheap" to program, but potentially far from efficient; ### Methods for specific subclasses will overwrite these: setAs("ANY", "denseMatrix", function(from) Matrix(from, sparse=FALSE)) setAs(from = "denseMatrix", to = "generalMatrix", as_geSimpl) ## dense to sparse: ## : if we do this, do it "right", i.e. preserve symmetric/triangular! ## setAs("denseMatrix", "dsparseMatrix", ## ## MM thought that as() will take the ``closest'' match; but that fails! ## ## function(from) as(as(from, "dgeMatrix"), "dsparseMatrix")) ## function(from) as(as(from, "dgeMatrix"), "dgCMatrix")) .dense2C <- function(from) { cl <- class(from) cld <- getClassDef(cl)## get it once (speedup) r <- .Call(dense_to_Csparse, from) if (extends(cld, "generalMatrix")) r else { ## i.e. triangular | symmetric ## FIXME: this is a waste for these matrices, particularly if packed if(extends(cld, "diagonalMatrix")) stop("diagonalMatrix in .dense2C() -- should not happen") sym <- extends(cld, "symmetricMatrix") ## Note: if(!sym), we have "triangular" if (extends(cld, "dMatrix")) as(r, if(sym) "dsCMatrix" else "dtCMatrix") else if(extends(cld, "nMatrix")) as(r, if(sym) "nsCMatrix" else "ntCMatrix") else if(extends(cld, "lMatrix")) as(r, if(sym) "lsCMatrix" else "ltCMatrix") else if(extends(cld, "zMatrix")) as(r, if(sym) "zsCMatrix" else "ztCMatrix") else stop("undefined method for class ", cl) } } setAs("denseMatrix", "CsparseMatrix", .dense2C) ## This sometimes fails (eg. for "lsyMatrix"), and we really want to ## use the generic ``go via Csparse'' (top of ./sparseMatrix.R) instead ## setAs("denseMatrix", "sparseMatrix", ## function(from) { ## cl <- class(from) ## cld <- getClassDef(cl) ## if (extends(cld, "generalMatrix")) ## .Call(dense_to_Csparse, from) ## else ## i.e. triangular | symmetric ## as_Csparse(from, cld) ## }) setAs("denseMatrix", "TsparseMatrix", function(from) as(.dense2C(from), "TsparseMatrix")) setMethod("show", signature(object = "denseMatrix"), function(object) prMatrix(object)) ##- ## FIXME: The following is only for the "dMatrix" objects that are not ##- ## "dense" nor "sparse" -- i.e. "packed" ones : ##- ## But these could be printed better -- "." for structural zeros. ##- setMethod("show", signature(object = "dMatrix"), prMatrix) ##- ## and improve this as well: ##- setMethod("show", signature(object = "pMatrix"), prMatrix) ##- ## this should now be superfluous [keep for safety for the moment]: setMethod("dim<-", signature(x = "denseMatrix", value = "ANY"), function(x, value) { if(!is.numeric(value) || length(value) != 2) stop("dim(.) value must be numeric of length 2") if(prod(dim(x)) != prod(value <- as.integer(value))) stop("dimensions don't match the number of cells") clx <- as.character(class(x)) # as.*(): drop attr if(substring(clx,2) == "geMatrix") { x@Dim <- value if(length(x@factors) > 0) x@factors <- list() x } else { ## other "denseMatrix" x <- as_geSimpl2(x, clx) dim(x) <- value x } }) ## Using "index" for indices should allow ## integer (numeric), logical, or character (names!) indices : ## use geClass() when 'i' or 'j' are missing: ## since symmetric, triangular, .. will not be preserved anyway: setMethod("[", signature(x = "denseMatrix", i = "index", j = "missing", drop = "logical"), function (x, i, drop) { r <- as(x, "matrix")[i, , drop=drop] if(is.null(dim(r))) r else as(r, geClass(x)) }) setMethod("[", signature(x = "denseMatrix", i = "missing", j = "index", drop = "logical"), function (x, j, drop) { r <- as(x, "matrix")[, j, drop=drop] if(is.null(dim(r))) r else as(r, geClass(x)) }) setMethod("[", signature(x = "denseMatrix", i = "index", j = "index", drop = "logical"), function (x, i, j, drop) { r <- callGeneric(x = as(x, "matrix"), i=i, j=j, drop=drop) if(is.null(dim(r))) r else { cl <- class(x) if(extends(cl, "symmetricMatrix") && length(i) == length(j) && all(i == j)) as(r, cl) ## keep original symmetric class else as_geClass(r, cl) } }) setMethod("[", signature(x = "denseMatrix", i = "matrix", j = "missing"),#drop="ANY" function(x, i, j, drop) { r <- as(x, "matrix")[ i ] if(is.null(dim(r))) r else as(r, geClass(x)) }) ## Now the "[<-" ones --- see also those in ./Matrix.R ## It's recommended to use setReplaceMethod() rather than setMethod("[<-",.) ## even though the former is currently just a wrapper for the latter ## FIXME: 1) These are far from efficient ## ----- setReplaceMethod("[", signature(x = "denseMatrix", i = "index", j = "missing", value = "replValue"), function (x, i, value) { r <- as(x, "matrix") r[i, ] <- value as(r, geClass(x)) }) setReplaceMethod("[", signature(x = "denseMatrix", i = "missing", j = "index", value = "replValue"), function (x, j, value) { r <- as(x, "matrix") r[, j] <- value as(r, geClass(x)) }) setReplaceMethod("[", signature(x = "denseMatrix", i = "index", j = "index", value = "replValue"), function (x, i, j, value) { r <- as(x, "matrix") r[i, j] <- value as_geClass(r, class(x)) ## was as(r, class(x)) }) setReplaceMethod("[", signature(x = "denseMatrix", i = "matrix", j = "missing", value = "replValue"), function(x, i, value) { r <- as(x, "matrix") r[ i ] <- value as(r, geClass(x)) }) setMethod("isSymmetric", signature(object = "denseMatrix"), function(object, tol = 100*.Machine$double.eps) { ## pretest: is it square? d <- dim(object) if(d[1] != d[2]) return(FALSE) ## else slower test if (is(object,"dMatrix")) isTRUE(all.equal(as(object, "dgeMatrix"), as(t(object), "dgeMatrix"), tol = tol)) else if (is(object, "nMatrix")) identical(as(object, "ngeMatrix"), as(t(object), "ngeMatrix")) else if (is(object, "lMatrix"))# not possible currently ## test for exact equality; FIXME(?): identical() too strict? identical(as(object, "lgeMatrix"), as(t(object), "lgeMatrix")) else if (is(object, "zMatrix")) stop("'zMatrix' not yet implemented") else if (is(object, "iMatrix")) stop("'iMatrix' not yet implemented") }) setMethod("isTriangular", signature(object = "triangularMatrix"), function(object, ...) TRUE) setMethod("isTriangular", signature(object = "denseMatrix"), isTriMat) setMethod("isDiagonal", signature(object = "denseMatrix"), .is.diagonal)