The R Project SVN R-packages

Rev

Rev 4320 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed 

#### Containing all  cbind2() and rbind2() methods for all our Matrices

###-- General -----------------------------------------------------------

###-- Dense, incl Diagonal ----------------------------------------------

###-- Sparse ------------------------------------------------------------

for(f in c("cbind2", "rbind2")) {
    setMethod(f, signature(x = "sparseMatrix", y = "matrix"),
          function(x, y) callGeneric(x, as_Csparse2(y)))
    setMethod(f, signature(x = "matrix", y = "sparseMatrix"),
          function(x, y) callGeneric(as_Csparse2(x), y))
}

## originally from ./Matrix.R : -------------------------------

## 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)
## using "atomicVector" not just "numeric"
setMethod("cbind2", signature(x = "Matrix", y = "atomicVector"),
      function(x, y) callGeneric(x, matrix(y, nrow = nrow(x))))
setMethod("cbind2", signature(x = "atomicVector", y = "Matrix"),
      function(x, y) callGeneric(matrix(x, nrow = nrow(y)), y))
setMethod("cbind2", signature(x = "ANY", y = "Matrix"),
      function(x, y) .bail.out.2(.Generic, class(x), class(y)))
setMethod("cbind2", signature(x = "Matrix", y = "ANY"),
      function(x, y) .bail.out.2(.Generic, class(x), class(y)))

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)
setMethod("rbind2", signature(x = "Matrix", y = "atomicVector"),
      function(x, y) callGeneric(x, matrix(y, ncol = ncol(x))))
setMethod("rbind2", signature(x = "atomicVector", y = "Matrix"),
      function(x, y) callGeneric(matrix(x, ncol = ncol(y)), y))
setMethod("rbind2", signature(x = "ANY", y = "Matrix"),
      function(x, y) .bail.out.2(.Generic, class(x), class(y)))
setMethod("rbind2", signature(x = "Matrix", y = "ANY"),
      function(x, y) .bail.out.2(.Generic, class(x), class(y)))

## 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)))
          })

## originally from ./denseMatrix.R : -------------------------------

### cbind2
setMethod("cbind2", signature(x = "denseMatrix", y = "numeric"),
      function(x, y) {
          d <- dim(x); nr <- d[1]; nc <- d[2]
          y <- rep(y, length.out = nr) # 'silent procrustes'
          ## beware of (packed) triangular, symmetric, ...
          x <- as(x, geClass(x))
          x@x <- c(x@x, as.double(y))
          x@Dim[2] <- nc + 1:1
          if(is.character(dn <- x@Dimnames[[2]]))
          x@Dimnames[[2]] <- c(dn, "")
          x
      })
## the same, (x,y) <-> (y,x):
setMethod("cbind2", signature(x = "numeric", y = "denseMatrix"),
      function(x, y) {
          d <- dim(y); nr <- d[1]; nc <- d[2]
          x <- rep(x, length.out = nr)
          y <- as(y, geClass(y))
          y@x <- c(as.double(x), y@x)
          y@Dim[2] <- nc + 1:1
          if(is.character(dn <- y@Dimnames[[2]]))
          y@Dimnames[[2]] <- c("", dn)
          y
      })


setMethod("cbind2", signature(x = "denseMatrix", y = "matrix"),
      function(x, y) callGeneric(x, as_geSimpl(y)))
setMethod("cbind2", signature(x = "matrix", y = "denseMatrix"),
      function(x, y) callGeneric(as_geSimpl(x), y))

setMethod("cbind2", signature(x = "denseMatrix", y = "denseMatrix"),
      function(x, y) {
          nr <- rowCheck(x,y)
          ncx <- x@Dim[2]
          ncy <- y@Dim[2]
          ## beware of (packed) triangular, symmetric, ...
          hasDN <- !is.null(dnx <- dimnames(x)) |
          !is.null(dny <- dimnames(y))
          x <- as(x, geClass(x))
          y <- as(y, geClass(y))
          x@x <- c(x@x, y@x)
          x@Dim[2] <- ncx + ncy
          if(hasDN) {
          ## R and S+ are different in which names they take
          ## if they differ -- but there's no warning in any case
          rn <- if(!is.null(dnx[[1]])) dnx[[1]] else dny[[1]]
          cx <- dnx[[2]] ; cy <- dny[[2]]
          cn <- if(is.null(cx) && is.null(cy)) NULL
          else c(if(!is.null(cx)) cx else rep.int("", ncx),
             if(!is.null(cy)) cy else rep.int("", ncy))
          x@Dimnames <- list(rn, cn)
          }
          x
      })

### rbind2 -- analogous to cbind2 --- more to do for @x though:

setMethod("rbind2", signature(x = "denseMatrix", y = "numeric"),
      function(x, y) {
          if(is.character(dn <- x@Dimnames[[1]])) dn <- c(dn, "")
          y <- rbind2(as(x,"matrix"), y)
          new(paste(.M.kind(y), "geMatrix", sep=''), x = c(y),
                  Dim = x@Dim + 1:0, Dimnames = list(dn, x@Dimnames[[2]]))
      })
## the same, (x,y) <-> (y,x):
setMethod("rbind2", signature(x = "numeric", y = "denseMatrix"),
      function(x, y) {
          if(is.character(dn <- y@Dimnames[[1]])) dn <- c("", dn)
          x <- rbind2(x, as(y,"matrix"))
          new(paste(.M.kind(x), "geMatrix", sep=''), x = c(x),
                  Dim = y@Dim + 1:0, Dimnames = list(dn, y@Dimnames[[2]]))
      })

setMethod("rbind2", signature(x = "denseMatrix", y = "matrix"),
      function(x, y) callGeneric(x, as_geSimpl(y)))
setMethod("rbind2", signature(x = "matrix", y = "denseMatrix"),
      function(x, y) callGeneric(as_geSimpl(x), y))

setMethod("rbind2", signature(x = "denseMatrix", y = "denseMatrix"),
      function(x, y) {
          nc <- colCheck(x,y)
          nrx <- x@Dim[1]
          nry <- y@Dim[1]
          dn <-
          if(!is.null(dnx <- dimnames(x)) |
             !is.null(dny <- dimnames(y))) {
              ## R and S+ are different in which names they take
              ## if they differ -- but there's no warning in any case
              list(if(is.null(rx <- dnx[[1]]) && is.null(ry <- dny[[1]]))
               NULL else
               c(if(!is.null(rx)) rx else rep.int("", nrx),
                 if(!is.null(ry)) ry else rep.int("", nry)),
               if(!is.null(dnx[[2]])) dnx[[2]] else dny[[2]])

          } else list(NULL, NULL)
          ## beware of (packed) triangular, symmetric, -> "cheap" (FIXME):
              x <- rbind2(as(x,"matrix"), as(y,"matrix"))
          new(paste(.M.kind(x), "geMatrix", sep=''), x = c(x),
                  Dim = c(nrx + nry, nc), Dimnames = dn)
      })

## originally from ./diagMatrix.R : --------------------------------------

## For diagonalMatrix:  preserve sparseness {not always optimal, but "the law"}

## hack to suppress the obnoxious dispatch ambiguity warnings:
diag2Sp <- function(x) suppressWarnings(as(x, "CsparseMatrix"))

setMethod("cbind2", signature(x = "diagonalMatrix", y = "sparseMatrix"),
      function(x,y) cbind2(diag2Sp(x), as_Csparse2(y)))
setMethod("cbind2", signature(x = "sparseMatrix", y = "diagonalMatrix"),
      function(x,y) cbind2(as_Csparse2(x), diag2Sp(y)))
setMethod("rbind2", signature(x = "diagonalMatrix", y = "sparseMatrix"),
      function(x,y) rbind2(diag2Sp(x), as_Csparse2(y)))
setMethod("rbind2", signature(x = "sparseMatrix", y = "diagonalMatrix"),
      function(x,y) rbind2(as_Csparse2(x), diag2Sp(y)))

## in order to evade method dispatch ambiguity, but still remain "general"
## we use this hack instead of signature  x = "diagonalMatrix"
for(cls in names(getClass("diagonalMatrix")@subclasses)) {

 setMethod("cbind2", signature(x = cls, y = "matrix"),
       function(x,y) cbind2(diag2Sp(x), as_Csparse2(y)))
 setMethod("cbind2", signature(x = "matrix", y = cls),
       function(x,y) cbind2(as_Csparse2(x), diag2Sp(y)))
 setMethod("rbind2", signature(x = cls, y = "matrix"),
       function(x,y) rbind2(diag2Sp(x), as_Csparse2(y)))
 setMethod("rbind2", signature(x = "matrix", y = cls),
       function(x,y) rbind2(as_Csparse2(x), diag2Sp(y)))

 ## These are already defined for "Matrix"
 ## -- repeated here for method dispatch disambiguation  {"design-FIXME" ?}
 setMethod("cbind2", signature(x = cls, y = "atomicVector"),
       function(x, y) callGeneric(x, matrix(y, nrow = nrow(x))))
 setMethod("cbind2", signature(x = "atomicVector", y = cls),
       function(x, y) callGeneric(matrix(x, nrow = nrow(y)), y))
 setMethod("rbind2", signature(x = cls, y = "atomicVector"),
       function(x, y) callGeneric(x, matrix(y, ncol = ncol(x))))
 setMethod("rbind2", signature(x = "atomicVector", y = cls),
       function(x, y) callGeneric(matrix(x, ncol = ncol(y)), y))
}


## originally from ./dsparseMatrix.R : --------------------------------

setMethod("cbind2", signature(x = "sparseMatrix", y = "sparseMatrix"),
          function(x, y) {
              nr <- rowCheck(x,y)
              ## beware of (packed) triangular, symmetric, ...
              hasDN <- !all(lapply(c(dnx <- dimnames(x),
                                     dny <- dimnames(y)), is.null))
              ans <- .Call(Csparse_horzcat,
                           as_Csparse2(x), as_Csparse2(y))
              if(hasDN) {
                  ## R and S+ are different in which names they take
                  ## if they differ -- but there's no warning in any case
                  rn <- if(!is.null(dnx[[1]])) dnx[[1]] else dny[[1]]
                  cx <- dnx[[2]] ; cy <- dny[[2]]
                  cn <- if(is.null(cx) && is.null(cy)) NULL
                  else c(if(!is.null(cx)) cx else rep.int("", ncol(x)),
                         if(!is.null(cy)) cy else rep.int("", ncol(y)))
                  ans@Dimnames <- list(rn, cn)
              }
              ans
          })

setMethod("rbind2", signature(x = "sparseMatrix", y = "sparseMatrix"),
          function(x, y) {
              nr <- colCheck(x,y)
              ## beware of (packed) triangular, symmetric, ...
              hasDN <- !all(lapply(c(dnx <- dimnames(x),
                                     dny <- dimnames(y)), is.null))
              ans <- .Call(Csparse_vertcat,
                           as_Csparse2(x), as_Csparse2(y))
              if(hasDN) {
                  ## R and S+ are different in which names they take
                  ## if they differ -- but there's no warning in any case
                  cn <- if(!is.null(dnx[[2]])) dnx[[2]] else dny[[2]]
                  rx <- dnx[[1]] ; ry <- dny[[1]]
                  rn <- if(is.null(rx) && is.null(ry)) NULL
                  else c(if(!is.null(rx)) rx else rep.int("", nrow(x)),
                         if(!is.null(ry)) ry else rep.int("", nrow(y)))
                  ans@Dimnames <- list(rn, cn)
              }
              ans
          })

if(FALSE) {
    ## FIXME
    ##------------- maybe a bit faster --- but too much to maintain
    ## would have to be done for "rbind2" as well ...
setMethod("cbind2", signature(x = "sparseMatrix", y = "numeric"),
          function(x, y) {
              d <- dim(x); nr <- d[1]; nc <- d[2]; cl <- class(x)
              x <- as_Csparse2(x)
              if(nr > 0) {
                  y <- rep(y, length.out = nr) # 'silent procrustes'
                  n0y <- y != 0
                  n.e <- length(x@i)
                  x@i <- c(x@i, (0:(nr-1))[n0y])
                  x@p <- c(x@p, n.e + sum(n0y))
                  x@x <- c(x@x, y[n0y])
              } else { ## nr == 0

              }
              x@Dim[2] <- nc + 1:1
              if(is.character(dn <- x@Dimnames[[2]]))
                  x@Dimnames[[2]] <- c(dn, "")
              x
          })
## the same, (x,y) <-> (y,x):
setMethod("cbind2", signature(x = "numeric", y = "sparseMatrix"),
          function(x, y) {
              d <- dim(y); nr <- d[1]; nc <- d[2]; cl <- class(y)
              y <- as_Csparse2(y)
              if(nr > 0) {
                  x <- rep(x, length.out = nr) # 'silent procrustes'
                  n0x <- x != 0
                  y@i <- c((0:(nr-1))[n0x], y@i)
                  y@p <- c(0:0, sum(n0x) + y@p)
                  y@x <- c(x[n0x], y@x)
              } else { ## nr == 0

              }
              y@Dim[2] <- nc + 1:1
              if(is.character(dn <- y@Dimnames[[2]]))
                  y@Dimnames[[2]] <- c(dn, "")
              y
          })

}## -- no longer