# SCM Repository

[matrix] Diff of /pkg/R/pMatrix.R
 [matrix] / pkg / R / pMatrix.R

# Diff of /pkg/R/pMatrix.R

revision 650, Tue Mar 15 01:53:58 2005 UTC revision 1654, Fri Oct 27 16:58:15 2006 UTC
# Line 1  Line 1
1  #### Permutation Matrices -- Coercion and Methods  #### Permutation Matrices -- Coercion and Methods
2
3    ## The typical   'constructor' : coerce from  'index'
4  setAs("integer", "pMatrix",  setAs("integer", "pMatrix",
5        function(from) {        function(from) {
6            n <- length(from)            n <- length(from)
7            new("pMatrix", Dim = rep.int(n, 2), perm = from)            nn <- names(from)
8              new("pMatrix", Dim = rep.int(n, 2), Dimnames = list(nn,nn),
9                  perm = from)
10        })        })
11
12    setAs("numeric", "pMatrix",
13          function(from)
14              if(all(from == (i <- as.integer(from)))) as(i, "pMatrix")
15              else stop("coercion to 'pMatrix' only works from integer numeric"))
16
17  setAs("pMatrix", "matrix",  setAs("pMatrix", "matrix",
18        function(from) {        function(from) {
19            fp <- from@perm            fp <- from@perm
20            diag(nrow = length(fp))[fp , ]            r <- diag(nrow = length(fp))[fp,]
21              if(.has.DN(from)) dimnames(r) <- from@Dimnames
22              r
23          })
24
25    ## coerce to 0/1 sparse matrix, i.e. sparse pattern
26    setAs("pMatrix", "ngTMatrix",
27          function(from) {
28              d <- from@Dim
29              new("ngTMatrix", i = seq_len(d[1]) - 1:1, j = from@perm - 1:1,
30                  Dim = d, Dimnames = from@Dimnames)
31        })        })
32
33    setAs("pMatrix", "TsparseMatrix",
34          function(from) as(from, "ngTMatrix"))
35
36  setMethod("solve", signature(a = "pMatrix", b = "missing"),  setMethod("solve", signature(a = "pMatrix", b = "missing"),
37            function(a, b) {            function(a, b) {
38                bp <- ap <- a@perm                bp <- ap <- a@perm
39                bp[ap] <- seq(along = ap)                bp[ap] <- seq_along(ap)
40                new("pMatrix", Dim = a@Dim, perm = bp)                new("pMatrix", perm = bp, Dim = a@Dim,
41                      Dimnames = rev(a@Dimnames))
42            }, valueClass = "pMatrix")            }, valueClass = "pMatrix")
43
44    setMethod("t", signature(x = "pMatrix"), function(x) solve(x))
45
46  setMethod("%*%", signature(x = "matrix", y = "pMatrix"),  setMethod("%*%", signature(x = "matrix", y = "pMatrix"),
47            function(x, y) x[ , y@perm], valueClass = "matrix")            function(x, y) x[ , y@perm], valueClass = "matrix")
48
49  setMethod("%*%", signature(x = "pMatrix", y = "matrix"),  setMethod("%*%", signature(x = "pMatrix", y = "matrix"),
50            function(x, y) y[x@perm ,], valueClass = "matrix")            function(x, y) y[x@perm ,], valueClass = "matrix")
51
52  setMethod("t", signature(x = "pMatrix"), function(x) solve(x))  setMethod("%*%", signature(x = "pMatrix", y = "pMatrix"),
53              function(x, y) {
54                  stopifnot(identical(d <- x@Dim, y@Dim))
55                  n <- d[1]
56                  ## FIXME: dimnames dealing: as with S3 matrix's  %*%
57                  x@perm <- x@perm[y@perm]
58                  x
59              })
60
61    setMethod("%*%", signature(x = "Matrix", y = "pMatrix"),
62              function(x, y) x[, y@perm])
63
64    setMethod("%*%", signature(x = "pMatrix", y = "Matrix"),
65              function(x, y) y[x@perm , ])

Legend:
 Removed from v.650 changed lines Added in v.1654