# SCM Repository

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

# View of /pkg/R/pMatrix.R

Fri Aug 19 16:57:49 2005 UTC (14 years, 6 months ago) by maechler
File size: 2029 byte(s)
```setAs( to "lgTMatrix" )
```
```#### 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
})

## coerce to 0/1 sparse matrix, i.e. sparse logical :
setAs("pMatrix", "lgTMatrix",
function(from) {
fp <- from@perm
d <- from@Dim
new("lgTMatrix", i = seq(length = d[1]) - 1:1, j = from@perm - 1:1,
Dim = d, Dimnames = from@Dimnames)
})

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

## FIXME: 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")
```