The R Project SVN R-packages

#### Permutation Matrices -- Coercion and Methods

setAs("integer", "pMatrix",
      function(from) {
          n <- length(from)
          nn <- names(from)
          new("pMatrix", Dim = rep.int(n, 2), Dimnames = list(nn,nn),
              perm = from)
      })

setAs("pMatrix", "matrix",
      function(from) {
      fp <- from@perm
      r <- diag(nrow = length(fp))[fp,]
      if(.has.DN(from)) dimnames(r) <- from@Dimnames
      r
      })

setMethod("solve", signature(a = "pMatrix", b = "missing"),
          function(a, b) {
              bp <- ap <- a@perm
              bp[ap] <- seq(along = ap)
              new("pMatrix", perm = bp, Dim = a@Dim,
                  Dimnames = rev(a@Dimnames))
          }, valueClass = "pMatrix")


setMethod("t", signature(x = "pMatrix"), function(x) solve(x))

setMethod("%*%", signature(x = "matrix", y = "pMatrix"),
      function(x, y) x[ , y@perm], valueClass = "matrix")

setMethod("%*%", signature(x = "pMatrix", y = "matrix"),
      function(x, y) y[x@perm ,], valueClass = "matrix")

setMethod("%*%", signature(x = "pMatrix", y = "pMatrix"),
      function(x, y) {
              stopifnot(identical(d <- x@Dim, y@Dim))
              n <- d[1]
              ## FIXME: dimnames dealing: as with S3 matrix's  %*%
              x@perm <- x@perm[y@perm]
              x
          })

## the following methods can be rewritten when "[" methods for
## dgeMatrix are available

setMethod("%*%", signature(x = "dgeMatrix", y = "pMatrix"),
      function(x, y) as(callGeneric(x, as(y, "matrix")), "dgeMatrix"),
          valueClass = "dgeMatrix")

setMethod("%*%", signature(x = "pMatrix", y = "dgeMatrix"),
          function(x, y) as(callGeneric(as(x, "matrix"), y), "dgeMatrix"),
          valueClass = "dgeMatrix")