The R Project SVN R-packages

### Define Methods that can be inherited for all subclasses


setAs("dMatrix", "matrix",
      function(from) as(as(from, "dgeMatrix"), "matrix"))

##-> "dMatrix" <--> "lMatrix"   ---> ./lMatrix.R

## these two are parallel to "n <-> l" in the above :
setAs("nMatrix", "dMatrix",
      function(from) {
      cl <- class(from)
      nCl <- sub("^n", "d", cl)
      r <- new(nCl)# default => no validity check; and copy slots:
      ## result is "same" (modulo care with the 'x' slot)
      sNams <- slotNames(cl)
      if(extends(cl, "sparseMatrix")) {# faster(not "nicer"): any(substr(cl,3,3) == c("C","T","R"))
          r@x <- rep.int(1., nnzero(from))
      } else {
          r@x <-  as.double(from@x)
          sNams <- sNams[sNams != "x"]
      }
      for(nm in sNams)
          slot(r, nm) <- slot(from, nm)
      r
      })

setAs("dMatrix", "nMatrix",
      function(from) {
      if(any(is.na(from@x)))
          stop("\"dMatrix\" object with NAs cannot be coerced to \"nMatrix\"")
      ## i.e. from@x are only TRUE (or FALSE in dense case)
      cl <- class(from)
      if(extends(cl, "diagonalMatrix")) # have no "ndi*" etc class
          cl <- class(from <- as(from, "sparseMatrix"))
      nCl <- sub("^d", "n", cl)
      sNams <- slotNames(if(extends(cl, "sparseMatrix")) .sp.class(cl) else cl)
      r <- new(nCl)# default => no validity check; and copy slots:
      for(nm in sNams)
          slot(r, nm) <- slot(from, nm)
      r
      })


## Methods for operations where one argument is integer
## No longer made use of (and confusing hence) since R version 2.1.0
## where "integer" goes as part of "numeric"

## Note: Use as.matrix() {not directly array()} :
##  1) to ensure consistency with "numeric" (non-matrix)
##  2) names -> dimnames {potentially}
## setMethod("%*%", signature(x = "dMatrix", y = "integer"),
##           function(x, y) callGeneric(x, as.numeric(y)))

## setMethod("%*%", signature(x = "integer", y = "dMatrix"),
##           function(x, y) callGeneric(as.numeric(x), y))

## setMethod("crossprod", signature(x = "dMatrix", y = "integer"),
##           function(x, y = NULL) callGeneric(x, as.numeric(y)))

## setMethod("crossprod", signature(x = "integer", y = "dMatrix"),
##           function(x, y = NULL) callGeneric(as.numeric(x), y))

## setMethod("solve", signature(a = "dMatrix", b = "integer"),
##           function(a, b, ...) callGeneric(a, as.numeric(b)))

setMethod("expm", signature(x = "dMatrix"),
      function(x) expm(as(x, "dgeMatrix")))


## Group Methods, see ?Arith (e.g.)
## -----
## >>> More specific methods for sub-classes (sparse), use these as "catch-all":

## the non-Ops ones :
setMethod("Math2",
          ## Assume that  Generic(u, k) |--> u for u in {0,1}
          ## which is true for round(), signif() ==> all structure maintained
          signature(x = "dMatrix"),
      function(x, digits) {
              x@x <- callGeneric(x@x, digits = digits)
              x
          })

if(getRversion() < "2.6.0" || R.version$`svn rev` < 42294) {
setMethod("Math2",
      signature(x = "dMatrix", digits = "missing"),
      function(x, digits)
           switch(.Generic,
              "signif" = callGeneric(x, digits = 6),
              callGeneric(x, digits = 0)) ## round(x) == round(x, 0)
      )
}

## at installation time:
summGenerics <- getGroupMembers("Summary")
## "max" "min" "range"  "prod" "sum"   "any" "all"
summGener1 <- summGenerics[match(summGenerics, c("prod","sum"), 0) == 0]

## [also needs extra work in ./AllGeneric.R ] :
setMethod("Summary", signature(x = "ddenseMatrix", na.rm = "ANY"),
      function(x, ..., na.rm) {
          clx <- getClassDef(class(x))
          if(extends(clx, "generalMatrix") || # ?geMatrix
         length(x@x) == prod(dim(x))) # not packed
          callGeneric(x@x, ..., na.rm = na.rm)
          else if(extends(clx, "symmetricMatrix")) { # and packed
          if(.Generic %in% summGener1)
              callGeneric(x@x, ..., na.rm = na.rm)
          else callGeneric(as(x, "dgeMatrix")@x, ..., na.rm = na.rm)
          }
          else { ## triangular , packed
          if(.Generic %in% summGener1)
              callGeneric(x@x, 0, ..., na.rm = na.rm)
          else callGeneric(as(x, "dgeMatrix")@x, ..., na.rm = na.rm)
          }
      })

setMethod("Summary", signature(x = "dsparseMatrix", na.rm = "ANY"),
      function(x, ..., na.rm) {
          ne <- prod(d <- dim(x))
          l.x <- length(x@x)
          if(l.x == ne) ## fully non-zero
          callGeneric(x@x, ..., na.rm = na.rm)
          else if(is(x, "symmetricMatrix") && l.x == choose(d[1]+1, 2)) {
          if(.Generic %in% summGener1)
              callGeneric(x@x, ..., na.rm = na.rm)
          else callGeneric(as(x, "generalMatrix")@x, ..., na.rm = na.rm)
          }
          else { ## has at least one structural 0
          callGeneric(
                  (if(.Generic %in% summGener1) x
                  else as(x, "generalMatrix"))@x,
                  0, ..., na.rm = na.rm)
          }
      })


## "Ops" ("Arith", "Compare", "Logic") --> ./Ops.R

## -- end{group generics} -----------------------




## Methods for single-argument transformations

setMethod("zapsmall", signature = list(x = "dMatrix"),
          function(x, digits = getOption("digits")) {
              x@x <- zapsmall(x@x, digits)
              x
          })

## -- end(single-argument transformations) ------