--- pkg/R/Matrix.R 2006/01/20 18:13:39 1189 +++ pkg/R/Matrix.R 2008/01/26 20:59:26 2110 @@ -1,5 +1,20 @@ #### Toplevel ``virtual'' class "Matrix" + +### Virtual coercions -- via smart "helpers" (-> ./Auxiliaries.R) + +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))) +setAs(from = "matrix", to = "Matrix", function(from) Matrix(from)) + ## ## probably not needed eventually: ## setAs(from = "ddenseMatrix", to = "matrix", ## function(from) { @@ -12,43 +27,37 @@ ## for 'Matrix' objects, as.array() should be equivalent: setMethod("as.array", signature(x = "Matrix"), function(x) as(x, "matrix")) +## head and tail apply to all Matrix objects for which subscripting is allowed: +setMethod("head", signature(x = "Matrix"), utils::head.matrix) +setMethod("tail", signature(x = "Matrix"), utils::tail.matrix) + +setMethod("drop", signature(x = "Matrix"), + function(x) if(all(dim(x) != 1)) x else drop(as(x, "matrix"))) + ## slow "fall back" method {subclasses should have faster ones}: setMethod("as.vector", signature(x = "Matrix", mode = "missing"), - function(x) as.vector(as(x, "matrix"))) + function(x) as.vector(as(x, "matrix"))) +## mainly need these for "dMatrix" or "lMatrix" respectively, but why not general: +setMethod("as.numeric", signature(x = "Matrix"), + function(x, ...) as.numeric(as.vector(x))) +setMethod("as.logical", signature(x = "Matrix"), + function(x, ...) as.logical(as.vector(x))) -## Note that isSymmetric is *not* exported -## but that "base" has an isSymmetric() S3-generic since R 2.3.0 +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"), function(object,tol) TRUE) setMethod("isSymmetric", signature(object = "triangularMatrix"), ## TRUE iff diagonal: function(object,tol) isDiagonal(object)) -if(paste(R.version\$major, R.version\$minor, sep=".") < "2.3") - ## need a "matrix" method as in R 2.3 and later - setMethod("isSymmetric", signature(object = "matrix"), - function(object, tol = 100*.Machine\$double.eps, ...) - { - ## pretest: is it square? - d <- dim(object) - if(d[1] != d[2]) return(FALSE) - ## for `broken' all.equal in R <= 2.2.x: - dn <- dimnames(object) - if(!identical(dn[1], dn[2])) return(FALSE) - test <- - if(is.complex(object)) - all.equal.numeric(object, Conj(t(object)), tol = tol, ...) - else # numeric, character, .. - all.equal(object, t(object), tol = tol, ...) - isTRUE(test) - }) - - setMethod("isTriangular", signature(object = "triangularMatrix"), - function(object,tol) TRUE) -setMethod("isTriangular", signature(object = "matrix"), - .is.triangular) + function(object, ...) TRUE) + +setMethod("isTriangular", signature(object = "matrix"), isTriMat) setMethod("isDiagonal", signature(object = "matrix"), .is.diagonal) @@ -56,7 +65,12 @@ setMethod("dim", signature(x = "Matrix"), function(x) x@Dim, valueClass = "integer") + +setMethod("length", "Matrix", function(x) prod(dim(x))) + setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames) + + ## not exported but used more than once for "dimnames<-" method : ## -- or do only once for all "Matrix" classes ?? dimnamesGets <- function (x, value) { @@ -75,20 +89,36 @@ setMethod("unname", signature("Matrix", force="missing"), function(obj) { obj@Dimnames <- list(NULL,NULL); obj}) +setMethod("all", signature(x = "Matrix"), + function(x, ..., na.rm) + callGeneric(as(x, "lMatrix"), ..., na.rm=na.rm)) + +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 <- function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL, - sparse = NULL) + sparse = NULL, forceCheck = FALSE) { - sparseDefault <- function(m) - prod(dim(m)) > 2*sum(as(m, "matrix") != 0) + sparseDefault <- function(m) prod(dim(m)) > 2*sum(isN0(as(m, "matrix"))) i.M <- is(data, "Matrix") - if(is.null(sparse) && (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) + doDN <- TRUE if (i.M) { + if(!missing(nrow) || !missing(ncol)|| !missing(byrow)) + warning("'nrow', 'ncol', etc, are disregarded when 'data' is \"Matrix\" already") sM <- is(data,"sparseMatrix") - if((sparse && sM) || (!sparse && !sM)) + if(!forceCheck && ((sparse && sM) || (!sparse && !sM))) return(data) ## else : convert dense <-> sparse -> at end } @@ -97,14 +127,34 @@ nrow <- ceiling(length(data)/ncol) else if (missing(ncol)) ncol <- ceiling(length(data)/nrow) - data <- .Internal(matrix(data, nrow, ncol, byrow)) - if(is.null(sparse)) - sparse <- sparseDefault(data) - dimnames(data) <- dimnames - } else if (!is.null(dimnames)) - dimnames(data) <- dimnames + 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 + stop("invalid 'data'"), + Dim = as.integer(c(nrow,ncol)), + Dimnames = if(is.null(dimnames)) list(NULL,NULL) + else dimnames) + } 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) + } + doDN <- FALSE + } else if(!missing(nrow) || !missing(ncol)|| !missing(byrow)) + warning("'nrow', 'ncol', etc, are disregarded for matrix 'data'") ## 'data' is now a "matrix" or "Matrix" + if (doDN && !is.null(dimnames)) + dimnames(data) <- dimnames ## check for symmetric / triangular / diagonal : isSym <- isSymmetric(data) @@ -114,11 +164,9 @@ if(isDiag) isDiag <- isDiagonal(data) -### TODO: Compare with as.Matrix() and its tests in ./dgeMatrix.R - ## Find proper matrix class 'cl' cl <- - if(isDiag) + if(isDiag && !isTRUE(sparse1)) "diagonalMatrix" # -> will automatically check for type else { ## consider it's type @@ -146,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) } @@ -157,18 +216,50 @@ setMethod("%*%", signature(x = "Matrix", y = "numeric"), function(x, y) callGeneric(x, as.matrix(y))) - setMethod("%*%", signature(x = "numeric", y = "Matrix"), - function(x, y) callGeneric(rbind(x), y)) + 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(rbind(x), y)) + 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 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))) + function(a, b, ...) callGeneric(a, Matrix(b))) +setMethod("solve", signature(a = "Matrix", b = "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))) ## bail-out methods in order to get better error messages setMethod("%*%", signature(x = "Matrix", y = "Matrix"), @@ -180,43 +271,96 @@ function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y))) setMethod("crossprod", signature(x = "ANY", y = "Matrix"), function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y))) +setMethod("tcrossprod", signature(x = "Matrix", y = "ANY"), + function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y))) +setMethod("tcrossprod", signature(x = "ANY", y = "Matrix"), + function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y))) + +## cheap fallbacks +setMethod("crossprod", signature(x = "Matrix", y = "Matrix"), + function(x, y = NULL) t(x) %*% y) +setMethod("tcrossprod", signature(x = "Matrix", y = "Matrix"), + function(x, y = NULL) x %*% t(y)) ## 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 +setMethod("chol", signature(x = "Matrix"), + function(x, pivot = FALSE) .bail.out.1(.Generic, class(x))) +setMethod("determinant", signature(x = "Matrix"), + function(x, logarithm = TRUE) .bail.out.1(.Generic, class(x))) + +setMethod("diag", signature(x = "Matrix"), + function(x, nrow, ncol) .bail.out.1(.Generic, class(x))) setMethod("t", signature(x = "Matrix"), function(x) .bail.out.1(.Generic, class(x))) -## Group Methods -setMethod("+", signature(e1 = "Matrix", e2 = "missing"), function(e1) e1) -## "fallback": -setMethod("-", signature(e1 = "Matrix", e2 = "missing"), - function(e1) { - warning("inefficient method used for \"- e1\"") - 0-e1 - }) +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", ...)) -## bail-outs: -setMethod("Compare", signature(e1 = "Matrix", e2 = "Matrix"), - function(e1, e2) { - d <- dimCheck(e1,e2) - .bail.out.2(.Generic, class(e1), class(e2)) - }) -setMethod("Compare", signature(e1 = "Matrix", e2 = "ANY"), - function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2))) -setMethod("Compare", signature(e1 = "ANY", e2 = "Matrix"), - function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2))) + +## 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)) + + ### -------------------------------------------------------------------------- ### ### Subsetting "[" and @@ -228,30 +372,87 @@ ## "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")) -## "FIXME:" -## How can we get at A[ ij ] where ij is (i,j) 2-column matrix? -## and A[ LL ] where LL is a logical *vector* -## -> [.data.frame uses nargs() - can we do this in the *generic* ? +## 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) +{ + nA <- nargs() + if(nA == 2) { ## M [ M >= 7 ] + ## FIXME: when both 'x' and 'i' are sparse, this can be very inefficient + as(x, geClass(x))@x[as.vector(i)] + ## -> error when lengths don't match + } else if(nA == 3) { ## M [ M[,1, drop=FALSE] >= 7, ] + stop("not-yet-implemented 'Matrix' subsetting") ## FIXME + + } else stop("nargs() = ", nA, + ". Extraneous illegal arguments inside '[ .. ]' (i.logical)?") +} +setMethod("[", signature(x = "Matrix", i = "lMatrix", j = "missing", + drop = "ANY"), + .M.sub.i.logical) +setMethod("[", signature(x = "Matrix", i = "logical", j = "missing", + drop = "ANY"), + .M.sub.i.logical) + + +## 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) ] or M [ ] + if(!is.integer(nc <- ncol(i))) + 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=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) + if(m == 0) return(vector(mode = .type.kind[.M.kind(x)])) + ## else + i1 <- i[,1] + i2 <- i[,2] + ## potentially inefficient -- FIXME -- + unlist(lapply(seq_len(m), function(j) x[i1[j], i2[j]])) + + } else stop("nargs() = ", nA, + ". Extraneous illegal arguments inside '[ .. ]' (i.2col)?") +} +setMethod("[", signature(x = "Matrix", i = "matrix", j = "missing"),# drop="ANY" + .M.sub.i.2col) ### "[<-" : ----------------- @@ -260,57 +461,97 @@ setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing", value = "ANY"),## double/logical/... function (x, value) { - x@x <- value - validObject(x)# check if type and lengths above match - x + ## Fails for 'nMatrix' ... FIXME : make sure have method there + x@x <- rep(value, length = length(x@x)) + validObject(x)# check if type and lengths above match + x }) -## Method for all 'Matrix' kinds (rather than incomprehensible error messages); +## A[ ij ] <- value, where ij is (i,j) 2-column matrix : +## ---------------- +## 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 or M [ Lmat ] <- value + if(!is.integer(nc <- ncol(i))) + 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 ...") + ## 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") + if(any(is.na(i))) + stop("NAs are not allowed in subscripted assignments") + if(any(i0 <- (i == 0))) # remove them + i <- i[ - which(i0, arr.ind = TRUE)[,"row"], ] + ## now have integer i >= 1 + m <- nrow(i) + ## mod.x <- .type.kind[.M.kind(x)] + if(length(value) > 0 && m %% length(value) != 0) + warning("number of items to replace is not a multiple of replacement length") + ## recycle: + value <- rep(value, length = m) + i1 <- i[,1] + i2 <- i[,2] + ## inefficient -- FIXME -- (also loses "symmetry" unnecessarily) + for(k in seq_len(m)) + x[i1[k], i2[k]] <- value[k] + + x + } else stop("nargs() = ", nA, + ". Extraneous illegal arguments inside '[ .. ]' ?") +} + +setReplaceMethod("[", signature(x = "Matrix", i = "matrix", j = "missing", + value = "replValue"), + .M.repl.i.2col) + + +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) + callGeneric(x=x, i=i, , value = as.vector(value))) + +setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", + value = "Matrix"), + 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) + callGeneric(x=x, i=i, j=j, value = c(value))) + ## (ANY,ANY,ANY) is used when no `real method' is implemented : setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", value = "ANY"), function (x, i, j, value) { if(!is.atomic(value)) - stop("RHS 'value' must match matrix class ", class(x)) + stop(sprintf("RHS 'value' (class %s) matches 'ANY', but must match matrix class %s", + class(value),class(x))) else stop("not-yet-implemented 'Matrix[<-' method") }) - - - -## NOTE: the following only works for R 2.2.x (and later) --- -## ---- *and* 'Matrix' must have been *installed* by R >= 2.2.x - -if(paste(R.version\$major, R.version\$minor, sep=".") >= "2.2") { - - ## The trivial methods : - setMethod("cbind2", signature(x = "Matrix", y = "NULL"), - function(x, y) x) - setMethod("cbind2", signature(x = "Matrix", y = "missing"), - function(x, y) x) - setMethod("cbind2", signature(x = "NULL", y="Matrix"), - function(x, y) x) - - setMethod("rbind2", signature(x = "Matrix", y = "NULL"), - function(x, y) x) - setMethod("rbind2", signature(x = "Matrix", y = "missing"), - function(x, y) x) - setMethod("rbind2", signature(x = "NULL", y="Matrix"), - function(x, y) x) - - ## Makes sure one gets x decent error message for the unimplemented cases: - setMethod("cbind2", signature(x = "Matrix", y = "Matrix"), - function(x, y) { - rowCheck(x,y) - stop(gettextf("cbind2() method for (%s,%s) not-yet defined", - class(x), class(y))) - }) - - ## Use a working fall back {particularly useful for sparse}: - ## FIXME: implement rbind2 via "cholmod" for C* and Tsparse ones - setMethod("rbind2", signature(x = "Matrix", y = "Matrix"), - function(x, y) { - colCheck(x,y) - t(cbind2(t(x), t(y))) - }) - -}## R-2.2.x and newer