The R Project SVN R-packages

### 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))
## Conceivably, could write
## setAs("matrix", "denseMatrix", ....) which was slightly more efficient than
##  Matrix(.)  but would have many things in common

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 never happen, please report!")

        sym <- extends(cld, "symmetricMatrix")
        ## Note: if(!sym), we have "triangular"

    if(sym) forceSymmetric(r)
    else {
        if     (extends(cld,"dMatrix")) as(r, "dtCMatrix")
        else if(extends(cld,"lMatrix")) as(r, "ltCMatrix")
        else if(extends(cld,"nMatrix")) as(r, "ntCMatrix")
        else if(extends(cld,"zMatrix")) as(r, "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, j, ..., drop) {
          if((na <- nargs()) == 3)
          r <- as(x, "matrix")[i, drop=drop]
          else if(na == 4)
          r <- as(x, "matrix")[i, , drop=drop]
          else stop("invalid nargs()= ",na)
          if(is.null(dim(r))) r else as(r, geClass(x))
      })

setMethod("[", signature(x = "denseMatrix", i = "missing", j = "index",
             drop = "logical"),
      function (x, i, 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, j, ..., value) {
             r <- as(x, "matrix")
##           message("`[<-` with nargs()= ",nargs())
             if((na <- nargs()) == 3)
             r[i] <- value
             else if(na == 4)
             r[i, ] <- value
             else stop("invalid nargs()= ",na)
             as(r, geClass(x))
         })

setReplaceMethod("[", signature(x = "denseMatrix", i = "missing", j = "index",
                value = "replValue"),
         function (x, i, 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",  # 2-col.matrix
                j = "missing", value = "replValue"),
         function(x, i, j, ..., 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)

## FIXME: Once we have integer (idense..),  sign(), abs(.) may need different:
setMethod("Math", signature(x = "denseMatrix"),
      function(x) callGeneric(as(x, "dMatrix")))
                                        # -> ./ddenseMatrix.R has next method

setMethod("rcond", signature(x = "denseMatrix", norm = "character"),
      function(x, norm, ...)
      rcond(as(as(x, "dMatrix"), "dgeMatrix"), norm=norm, ...))

setMethod("symmpart", signature(x = "denseMatrix"),
      function(x) symmpart(as(x, "dMatrix")))
setMethod("skewpart", signature(x = "denseMatrix"),
      function(x) skewpart(as(x, "dMatrix")))

setMethod("is.na", signature(x = "denseMatrix"),
      function(x) {
          if(any((inax <- is.na(x@x)))) {
          r <- as(x, "lMatrix")#-> logical x-slot
          r@x <- inax
          as(r, "nMatrix")
          } else {
          d <- x@Dim
          new("ngCMatrix", Dim = d, Dimnames = dimnames(x),
              i = integer(0), p = rep.int(0L, d[2]+1L))
          }
      })