--- pkg/R/Matrix.R 2007/01/30 17:41:02 1751 +++ pkg/R/Matrix.R 2008/01/26 20:59:26 2110 @@ -3,9 +3,13 @@ ### Virtual coercions -- via smart "helpers" (-> ./Auxiliaries.R) -setAs("Matrix", "sparseMatrix", function(from) as_Csparse(from)) +setAs("Matrix", "sparseMatrix", function(from) as(from, "CsparseMatrix")) +setAs("Matrix", "CsparseMatrix", function(from) as_Csparse(from)) setAs("Matrix", "denseMatrix", function(from) as_dense(from)) +## Maybe TODO: +## setAs("Matrix", "nMatrix", function(from) ....) + ## Most of these work; this is a last resort: setAs(from = "Matrix", to = "matrix", # do *not* call base::as.matrix() here: function(from) .bail.out.2("coerce", class(from), class(to))) @@ -40,6 +44,8 @@ setMethod("as.logical", signature(x = "Matrix"), function(x, ...) as.logical(as.vector(x))) +setMethod("cov2cor", signature(V = "Matrix"), + function(V) as(cov2cor(as(V, "matrix")), "dpoMatrix")) ## "base" has an isSymmetric() S3-generic since R 2.3.0 setMethod("isSymmetric", signature(object = "symmetricMatrix"), @@ -84,12 +90,15 @@ function(obj) { obj@Dimnames <- list(NULL,NULL); obj}) setMethod("all", signature(x = "Matrix"), - function(x, ..., na.rm) { x <- as(x, "lMatrix"); callGeneric()}) -setMethod("any", signature(x = "Matrix"), - function(x, ..., na.rm) { x <- as(x, "lMatrix"); callGeneric()}) + function(x, ..., na.rm) + callGeneric(as(x, "lMatrix"), ..., na.rm=na.rm)) -setMethod("!", "Matrix", function(e1) !as(e1, "lMatrix")) +setMethod("any", signature(x = "Matrix"), + function(x, ..., na.rm) + callGeneric(as(x, "lMatrix"), ..., na.rm=na.rm)) +## NOTE: "&" and "|" are now in group "Logic" c "Ops" --> ./Ops.R +## "!" is in ./not.R Matrix <- @@ -99,7 +108,8 @@ sparseDefault <- function(m) prod(dim(m)) > 2*sum(isN0(as(m, "matrix"))) i.M <- is(data, "Matrix") - + if(!i.M && inherits(data, "table")) # special treatment + class(data) <- "matrix" # "matrix" first for S4 dispatch if(is.null(sparse1 <- sparse) && (i.M || is(data, "matrix"))) sparse <- sparseDefault(data) @@ -120,6 +130,7 @@ if(length(data) == 1 && is0(data) && !identical(sparse, FALSE)) { ## Matrix(0, ...) : always sparse unless "sparse = FALSE": if(is.null(sparse)) sparse1 <- sparse <- TRUE + i.M <- sM <- TRUE ## will be sparse: do NOT construct full matrix! data <- new(if(is.numeric(data)) "dgTMatrix" else if(is.logical(data)) "lgTMatrix" else @@ -127,11 +138,15 @@ Dim = as.integer(c(nrow,ncol)), Dimnames = if(is.null(dimnames)) list(NULL,NULL) else dimnames) - } else { ## normal case - data <- .Internal(matrix(data, nrow, ncol, byrow)) + } else { ## normal case - using .Internal() to avoid more copying + if(getRversion() >= "2.7.0") + data <- .Internal(matrix(data, nrow, ncol, byrow, dimnames)) + else { + data <- .Internal(matrix(data, nrow, ncol, byrow)) + dimnames(data) <- dimnames + } if(is.null(sparse)) sparse <- sparseDefault(data) - dimnames(data) <- dimnames } doDN <- FALSE } else if(!missing(nrow) || !missing(ncol)|| !missing(byrow)) @@ -179,7 +194,18 @@ }, sep="") } - ## Now coerce and return + ## Can we coerce and be done? + if(!canCoerce(data,cl)) { ## try to coerce ``via'' virtual classes + if(sparse && !sM) + data <- as(data, "sparseMatrix") + else if(!sparse && !is(data, "denseMatrix")) + data <- as(data, "denseMatrix") + if(isTri && !is(data, "triangularMatrix")) + data <- as(data, "triangularMatrix") + else if(isSym && !is(data, "symmetricMatrix")) + data <- as(data, "symmetricMatrix") + } + ## now coerce in any case .. maybe producing sensible error message: as(data, cl) } @@ -190,31 +216,48 @@ setMethod("%*%", signature(x = "Matrix", y = "numeric"), function(x, y) callGeneric(x, as.matrix(y))) - setMethod("%*%", signature(x = "numeric", y = "Matrix"), function(x, y) callGeneric(matrix(x, nrow = 1, byrow=TRUE), y)) +setMethod("%*%", signature(x = "Matrix", y = "matrix"), + function(x, y) callGeneric(x, Matrix(y))) +setMethod("%*%", signature(x = "matrix", y = "Matrix"), + function(x, y) callGeneric(Matrix(x), y)) + + setMethod("crossprod", signature(x = "Matrix", y = "numeric"), function(x, y = NULL) callGeneric(x, as.matrix(y))) setMethod("crossprod", signature(x = "numeric", y = "Matrix"), function(x, y = NULL) callGeneric(as.matrix(x), y)) +setMethod("crossprod", signature(x = "Matrix", y = "matrix"), + function(x, y = NULL) callGeneric(x, Matrix(y))) +setMethod("crossprod", signature(x = "matrix", y = "Matrix"), + function(x, y = NULL) callGeneric(Matrix(x), y)) + ## The as.matrix() promotion seems illogical to MM, ## but is according to help(tcrossprod, package = "base") : setMethod("tcrossprod", signature(x = "Matrix", y = "numeric"), function(x, y = NULL) callGeneric(x, as.matrix(y))) setMethod("tcrossprod", signature(x = "numeric", y = "Matrix"), function(x, y = NULL) callGeneric(as.matrix(x), y)) +setMethod("tcrossprod", signature(x = "Matrix", y = "matrix"), + function(x, y = NULL) callGeneric(x, Matrix(y))) +setMethod("tcrossprod", signature(x = "matrix", y = "Matrix"), + function(x, y = NULL) callGeneric(Matrix(x), y)) -## maybe not optimal +## maybe not 100% optimal, but elegant: setMethod("solve", signature(a = "Matrix", b = "missing"), function(a, b, ...) solve(a, Diagonal(nrow(a)))) setMethod("solve", signature(a = "Matrix", b = "numeric"), - function(a, b, ...) callGeneric(a, as.matrix(b))) -## when no sub-class method is found, bail out + function(a, b, ...) callGeneric(a, Matrix(b))) setMethod("solve", signature(a = "Matrix", b = "matrix"), - function(a, b, ...) .bail.out.2("solve", class(a), "matrix")) + function(a, b, ...) callGeneric(a, Matrix(b))) +setMethod("solve", signature(a = "matrix", b = "Matrix"), + function(a, b, ...) callGeneric(Matrix(a), b)) + +## when no sub-class method is found, bail out setMethod("solve", signature(a = "Matrix", b = "Matrix"), function(a, b, ...) .bail.out.2("solve", class(a), class(b))) @@ -241,13 +284,18 @@ ## There are special sparse methods; this is a "fall back": setMethod("kronecker", signature(X = "Matrix", Y = "ANY", - FUN = "ANY", make.dimnames = "ANY"), - function(X, Y, FUN, make.dimnames, ...) { - X <- as(X, "matrix") ; Matrix(callGeneric()) }) + FUN = "ANY", make.dimnames = "ANY"), + function(X, Y, FUN, make.dimnames, ...) { + if(is(X, "sparseMatrix")) + warning("using slow kronecker() method") + X <- as(X, "matrix") ; Matrix(callGeneric()) }) + setMethod("kronecker", signature(X = "ANY", Y = "Matrix", - FUN = "ANY", make.dimnames = "ANY"), - function(X, Y, FUN, make.dimnames, ...) { - Y <- as(Y, "matrix") ; Matrix(callGeneric()) }) + FUN = "ANY", make.dimnames = "ANY"), + function(X, Y, FUN, make.dimnames, ...) { + if(is(Y, "sparseMatrix")) + warning("using slow kronecker() method") + Y <- as(Y, "matrix") ; Matrix(callGeneric()) }) ## FIXME: All of these should never be called @@ -261,9 +309,57 @@ setMethod("t", signature(x = "Matrix"), function(x) .bail.out.1(.Generic, class(x))) +setMethod("norm", signature(x = "Matrix", type = "character"), + function(x, type, ...) .bail.out.1(.Generic, class(x))) +setMethod("rcond", signature(x = "Matrix", type = "character"), + function(x, type, ...) .bail.out.1(.Generic, class(x))) + + +## for all : +setMethod("norm", signature(x = "ANY", type = "missing"), + function(x, type, ...) norm(x, type = "O", ...)) +setMethod("rcond", signature(x = "ANY", type = "missing"), + function(x, type, ...) rcond(x, type = "O", ...)) + + + + + +## MM: More or less "Cut & paste" from +## --- diff.default() from R/src/library/base/R/diff.R : +setMethod("diff", signature(x = "Matrix"), + function(x, lag = 1, differences = 1, ...) { + if (length(lag) > 1 || length(differences) > 1 || + lag < 1 || differences < 1) + stop("'lag' and 'differences' must be integers >= 1") + xlen <- nrow(x) + if (lag * differences >= xlen) + return(x[,FALSE][0]) # empty of proper mode + + i1 <- -1:-lag + for (i in 1:differences) + x <- x[i1, , drop = FALSE] - + x[-nrow(x):-(nrow(x)-lag+1), , drop = FALSE] + x + }) + +setMethod("image", "Matrix", + function(x, ...) { # coercing to sparse is not inefficient, + ## since we need 'i' and 'j' for levelplot() + x <- as(as(x, "sparseMatrix"), "dMatrix") + callGeneric() + }) + + ## Group Methods ##-> see ./Ops.R +## ~~~~~ +## For all non-dMatrix objects, and note that "all" and "any" have their own +setMethod("Summary", signature(x = "Matrix", na.rm = "ANY"), + function(x, ..., na.rm) + callGeneric(as(x,"dMatrix"), ..., na.rm = na.rm)) + ### -------------------------------------------------------------------------- ### @@ -276,31 +372,42 @@ ## "x[]": setMethod("[", signature(x = "Matrix", i = "missing", j = "missing", drop = "ANY"), - function (x, i, j, drop) x) + function (x, i, j, ..., drop) x) ## missing 'drop' --> 'drop = TRUE' ## ----------- ## select rows setMethod("[", signature(x = "Matrix", i = "index", j = "missing", drop = "missing"), - function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE)) + function(x,i,j, ..., drop) { + if(nargs() == 2) { ## e.g. M[0] , M[TRUE], M[1:2] + if(any(i) || prod(dim(x)) == 0) + as.vector(x)[i] + else ## save memory + as.vector(x[1,1])[FALSE] + } else { + callGeneric(x, i=i, , drop=TRUE) + ## ^^ + } + }) + ## select columns setMethod("[", signature(x = "Matrix", i = "missing", j = "index", drop = "missing"), - function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE)) + function(x,i,j, ..., drop) callGeneric(x, j=j, drop= TRUE)) setMethod("[", signature(x = "Matrix", i = "index", j = "index", drop = "missing"), - function(x,i,j, drop) callGeneric(x, i=i, j=j, drop= TRUE)) + function(x,i,j, ..., drop) callGeneric(x, i=i, j=j, drop= TRUE)) ## bail out if any of (i,j,drop) is "non-sense" setMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", drop = "ANY"), - function(x,i,j, drop) + function(x,i,j, ..., drop) stop("invalid or not-yet-implemented 'Matrix' subsetting")) ## logical indexing, such as M[ M >= 7 ] *BUT* also M[ M[,1] >= 3,], ## The following is *both* for M [ ] ## and also for M [ , ] -.M.sub.i.logical <- function (x, i, j, drop) +.M.sub.i.logical <- function (x, i, j, ..., drop) { nA <- nargs() if(nA == 2) { ## M [ M >= 7 ] @@ -311,7 +418,7 @@ stop("not-yet-implemented 'Matrix' subsetting") ## FIXME } else stop("nargs() = ", nA, - ". Extraneous illegal arguments inside '[ .. ]' ?") + ". Extraneous illegal arguments inside '[ .. ]' (i.logical)?") } setMethod("[", signature(x = "Matrix", i = "lMatrix", j = "missing", drop = "ANY"), @@ -321,16 +428,16 @@ .M.sub.i.logical) -## A[ ij ] where ij is (i,j) 2-column matrix : -.M.sub.i.2col <- function (x, i, j, drop) +## A[ ij ] where ij is (i,j) 2-column matrix -- but also when that is logical mat! +.M.sub.i.2col <- function (x, i, j, ..., drop) { nA <- nargs() - if(nA == 2) { ## M [ cbind(ii,jj) ] + if(nA == 2) { ## M [ cbind(ii,jj) ] or M [ ] if(!is.integer(nc <- ncol(i))) - stop("'i' has no integer column number", - " should never happen; please report") + stop(".M.sub.i.2col(): 'i' has no integer column number;\n", + "should never happen; please report") if(is.logical(i)) - return(.M.sub.i.logical(x,i,j,drop)) + return(.M.sub.i.logical(x, i=i)) # call with 2 args! else if(!is.numeric(i) || nc != 2) stop("such indexing must be by logical or 2-column numeric matrix") m <- nrow(i) @@ -342,7 +449,7 @@ unlist(lapply(seq_len(m), function(j) x[i1[j], i2[j]])) } else stop("nargs() = ", nA, - ". Extraneous illegal arguments inside '[ .. ]' ?") + ". Extraneous illegal arguments inside '[ .. ]' (i.2col)?") } setMethod("[", signature(x = "Matrix", i = "matrix", j = "missing"),# drop="ANY" .M.sub.i.2col) @@ -361,21 +468,24 @@ }) ## A[ ij ] <- value, where ij is (i,j) 2-column matrix : -## ---------------- The cheap general method --- FIXME: provide special ones -.M.repl.i.2col <- function (x, i, j, value) +## ---------------- +## The cheap general method --- FIXME: provide special ones; done for Tsparse.. +## NOTE: need '...' below such that setMethod() does +## not use .local() such that nargs() will work correctly: +.M.repl.i.2col <- function (x, i, j, ..., value) { nA <- nargs() - if(nA == 3) { ## M [ cbind(ii,jj) ] <- value + if(nA == 3) { ## M [ cbind(ii,jj) ] <- value or M [ Lmat ] <- value if(!is.integer(nc <- ncol(i))) - stop("'i' has no integer column number", - " should never happen; please report") + stop(".M.repl.i.2col(): 'i' has no integer column number;\n", + "should never happen; please report") else if(!is.numeric(i) || nc != 2) stop("such indexing must be by logical or 2-column numeric matrix") if(is.logical(i)) { message(".M.repl.i.2col(): drop 'matrix' case ...") - i <- c(i) # drop "matrix" - return( callNextMethod() ) - } + ## c(i) : drop "matrix" to logical vector + return( callGeneric(x, i=c(i), value=value) ) + } if(!is.integer(i)) storage.mode(i) <- "integer" if(any(i < 0)) stop("negative values are not allowed in a matrix subscript") @@ -406,24 +516,31 @@ .M.repl.i.2col) -setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", +setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "ANY", + value = "Matrix"), + function (x, i, j, ..., value) + callGeneric(x=x, , j=j, value = as.vector(value))) + +setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "missing", value = "Matrix"), - function (x, i, j, value) { -### *TEMPORARY* diagnostic output: -## cat("[i,j] <- :\n = x :") -## str(x) -## cat(" = value :") -## str(value) -## cat("i :"); if(!missing(i)) str(i) else cat("\n") -## cat("j :"); if(!missing(j)) str(j) else cat("\n") + function (x, i, j, ..., value) + callGeneric(x=x, i=i, , value = as.vector(value))) - callGeneric(x=x, i=i, j=j, value = as.vector(value)) - }) setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", value = "Matrix"), - function (x, i, j, value) + function (x, i, j, ..., value) callGeneric(x=x, i=i, j=j, value = as.vector(value))) +setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "ANY", + value = "matrix"), + function (x, i, j, ..., value) + callGeneric(x=x, , j=j, value = c(value))) + +setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "missing", + value = "matrix"), + function (x, i, j, ..., value) + callGeneric(x=x, i=i, , value = c(value))) + setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", value = "matrix"), function (x, i, j, value)