The R Project SVN R-packages

Rev

Rev 1283 | Rev 1866 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 1283 Rev 1287
Line 1... Line 1...
1 
#### Permutation Matrices -- Coercion and Methods
 1 
#### Permutation Matrices -- Coercion and Methods
2 
 
 2 
 
3 
setAs("integer", "pMatrix",
 3 
setAs("integer", "pMatrix",
4 
      function(from) {
 4 
      function(from) {
5 
          n <- length(from)
 5 
          n <- length(from)
- 
 
 6 
          nn <- names(from)
6 
          new("pMatrix", Dim = rep.int(n, 2), perm = from)
 7 
          new("pMatrix", Dim = rep.int(n, 2), Dimnames = list(nn,nn),
- 
 
 8 
              perm = from)
7 
      })
 9 
      })
8 
 
 10 
 
9 
setAs("pMatrix", "matrix",
 11 
setAs("pMatrix", "matrix",
10 
      function(from) {
 12 
      function(from) {
11 
          fp <- from@perm
 13 
	  fp <- from@perm
12 
          diag(nrow = length(fp))[fp , ]
 14 
	  r <- diag(nrow = length(fp))[fp,]
- 
 
 15 
	  if(.has.DN(from)) dimnames(r) <- from@Dimnames
- 
 
 16 
	  r
13 
      })
 17 
      })
14 
 
 18 
 
15 
setMethod("solve", signature(a = "pMatrix", b = "missing"),
 19 
setMethod("solve", signature(a = "pMatrix", b = "missing"),
16 
          function(a, b) {
 20 
          function(a, b) {
17 
              bp <- ap <- a@perm
 21 
              bp <- ap <- a@perm
18 
              bp[ap] <- seq(along = ap)
 22 
              bp[ap] <- seq(along = ap)
19 
              new("pMatrix", Dim = a@Dim, perm = bp)
 23 
              new("pMatrix", perm = bp, Dim = a@Dim,
- 
 
 24 
                  Dimnames = rev(a@Dimnames))
20 
          }, valueClass = "pMatrix")
 25 
          }, valueClass = "pMatrix")
21 
 
 26 
 
- 
 
 27 
 
22 
setMethod("t", signature(x = "pMatrix"), function(x) solve(x))
 28 
setMethod("t", signature(x = "pMatrix"), function(x) solve(x))
23 
 
 29 
 
24 
setMethod("%*%", signature(x = "matrix", y = "pMatrix"),
 30 
setMethod("%*%", signature(x = "matrix", y = "pMatrix"),
25 
	  function(x, y) x[ , y@perm], valueClass = "matrix")
 31 
	  function(x, y) x[ , y@perm], valueClass = "matrix")
26 
 
 32 
 
27 
setMethod("%*%", signature(x = "pMatrix", y = "matrix"),
 33 
setMethod("%*%", signature(x = "pMatrix", y = "matrix"),
28 
	  function(x, y) y[x@perm ,], valueClass = "matrix")
 34 
	  function(x, y) y[x@perm ,], valueClass = "matrix")
29 
 
 35 
 
- 
 
 36 
setMethod("%*%", signature(x = "pMatrix", y = "pMatrix"),
- 
 
 37 
	  function(x, y) {
- 
 
 38 
              stopifnot(identical(d <- x@Dim, y@Dim))
- 
 
 39 
              n <- d[1]
- 
 
 40 
              ## FIXME: dimnames dealing: as with S3 matrix's  %*%
- 
 
 41 
              x@perm <- x@perm[y@perm]
- 
 
 42 
              x
- 
 
 43 
          })
- 
 
 44 
 
30 
## the following methods can be rewritten when "[" methods for
 45 
## the following methods can be rewritten when "[" methods for
31 
## dgeMatrix are available
46 
## dgeMatrix are available
32 
 
 47 
 
33 
setMethod("%*%", signature(x = "dgeMatrix", y = "pMatrix"),
 48 
setMethod("%*%", signature(x = "dgeMatrix", y = "pMatrix"),
34 
	  function(x, y) as(callGeneric(x, as(y, "matrix")), "dgeMatrix"),
 49 
	  function(x, y) as(callGeneric(x, as(y, "matrix")), "dgeMatrix"),
35 
          valueClass = "dgeMatrix")
 50 
          valueClass = "dgeMatrix")
36 
 
 51