https://github.com/cran/Matrix
Tip revision: 0d6bb027b0d1a4bfc551f6d5d42cbbd7bd7a5e4d authored by Douglas Bates on 13 September 2006, 00:00:00 UTC
version 0.995-18
version 0.995-18
Tip revision: 0d6bb02
diagMatrix.R
## Purpose: Constructor of diagonal matrices -- ~= diag() ,
## but *not* diag() extractor!
Diagonal <- function(n, x = NULL)
{
## Allow Diagonal(4) and Diagonal(x=1:5)
if(missing(n))
n <- length(x)
else {
stopifnot(length(n) == 1, n == as.integer(n), n >= 0)
n <- as.integer(n)
}
if(missing(x)) # unit diagonal matrix
new("ddiMatrix", Dim = c(n,n), diag = "U")
else {
stopifnot(length(x) == n)
if(is.logical(x))
cl <- "ldiMatrix"
else {
cl <- "ddiMatrix"
x <- as.numeric(x)
}
new(cl, Dim = c(n,n), diag = "N", x = x)
}
}
setAs("diagonalMatrix", "triangularMatrix",
function(from) {
n <- from@Dim[1]
i <- seq(length = n)
x <- from@x
new(if(is.numeric(x)) "dtTMatrix" else "ltTMatrix",
diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,
x = x, i = i, j = i)
})
setAs("diagonalMatrix", "matrix",
function(from) {
n <- from@Dim[1]
diag(x = if(from@diag == "U") { if(is.numeric(from@x)) 1. else TRUE
} else from@x,
nrow = n, ncol = n)
})
setAs("diagonalMatrix", "generalMatrix",
function(from) {
x <- as(from, "matrix")
as(x,
if(is.logical(x)) "lgeMatrix"
## Not yet:
## else if(is.complex(x)) "zgeMatrix"
## else if(is.integer(x)) "igeMatrix"
else "dgeMatrix")
})
setAs("ddiMatrix", "dgTMatrix",
function(from) {
n <- from@Dim[1]
i <- seq(length = n) - 1:1
new("dgTMatrix", i = i, j = i,
x = if(from@diag == "U") rep(1,n) else from@x,
Dim = c(n,n), Dimnames = from@Dimnames) })
setAs("ddiMatrix", "dgCMatrix",
function(from) as(as(from, "dgTMatrix"), "dgCMatrix"))
setAs("ldiMatrix", "lgTMatrix",
function(from) {
n <- from@Dim[1]
i <- (if(from@diag == "U") seq(length = n) else which(from@x)) - 1:1
new("lgTMatrix", i = i, j = i,
Dim = c(n,n), Dimnames = from@Dimnames) })
setAs("ldiMatrix", "lgCMatrix",
function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))
setAs("diagonalMatrix", "sparseMatrix",
function(from)
as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))
if(FALSE) # now have faster "ddense" -> "dge"
setAs("ddiMatrix", "dgeMatrix",
function(from) as(as(from, "matrix"), "dgeMatrix"))
setAs("matrix", "diagonalMatrix",
function(from) {
d <- dim(from)
if(d[1] != (n <- d[2])) stop("non-square matrix")
if(any(from[row(from) != col(from)] != 0))
stop("has non-zero off-diagonal entries")
x <- diag(from)
if(is.logical(x)) {
cl <- "ldiMatrix"
uni <- all(x)
} else {
cl <- "ddiMatrix"
uni <- all(x == 1)
storage.mode(x) <- "double"
}
new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",
x = if(uni) x[FALSE] else x)
})
## ``generic'' coercion to diagonalMatrix : build on isDiagonal() and diag()
setAs("Matrix", "diagonalMatrix",
function(from) {
d <- dim(from)
if(d[1] != (n <- d[2])) stop("non-square matrix")
if(!isDiagonal(from)) stop("matrix is not diagonal")
## else:
x <- diag(from)
if(is.logical(x)) {
cl <- "ldiMatrix"
uni <- all(x)
} else {
cl <- "ddiMatrix"
uni <- all(x == 1)
storage.mode(x) <- "double"
}
new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",
x = if(uni) x[FALSE] else x)
})
setMethod("t", signature(x = "diagonalMatrix"),
function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })
setMethod("isDiagonal", signature(object = "diagonalMatrix"),
function(object) TRUE)
setMethod("isTriangular", signature(object = "diagonalMatrix"),
function(object) TRUE)
setMethod("isSymmetric", signature(object = "diagonalMatrix"),
function(object) TRUE)
setMethod("diag", signature(x = "diagonalMatrix"),
function(x = 1, nrow, ncol = n) {
if(x@diag == "U")
rep.int(if(is.logical(x@x)) TRUE else 1, x@Dim[1])
else x@x
})
setMethod("!", "ldiMatrix", function(e1) {
if(e1@diag == "N")
e1@x <- !e1@x
else { ## "U"
e1@diag <- "N"
e1@x <- rep.int(FALSE, e1@Dim[1])
}
x
})
## Basic Matrix Multiplication {many more to add}
## FIXME: extend this for 'ldi', i.e. do "diagonalMatrix"
diagdiagprod <- function(x, y) {
if(any(dim(x) != dim(y))) stop("non-matching dimensions")
if(x@diag != "U") {
if(y@diag != "U") x@x <- x@x * y@x
return(x)
} else ## x is unit diagonal
return(y)
}
setMethod("%*%", signature(x = "ddiMatrix", y = "ddiMatrix"),
diagdiagprod, valueClass = "ddiMatrix")
formals(diagdiagprod) <- alist(x=, y=NULL)
setMethod("crossprod", signature(x = "ddiMatrix", y = "ddiMatrix"),
diagdiagprod, valueClass = "ddiMatrix")
setMethod("tcrossprod", signature(x = "ddiMatrix", y = "ddiMatrix"),
diagdiagprod, valueClass = "ddiMatrix")
diagmatprod <- function(x, y) {
dx <- dim(x)
dy <- dim(y)
if(dx[2] != dy[1]) stop("non-matching dimensions")
n <- dx[1]
as(if(x@diag == "U") y else x@x * y, "Matrix")
}
setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"),
diagmatprod)
formals(diagmatprod) <- alist(x=, y=NULL)
setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),
diagmatprod)
diagdgeprod <- function(x, y) {
dx <- dim(x)
dy <- dim(y)
if(dx[2] != dy[1]) stop("non-matching dimensions")
if(x@diag != "U")
y@x <- x@x * y@x
y
}
setMethod("%*%", signature(x = "diagonalMatrix", y = "dgeMatrix"),
diagdgeprod, valueClass = "dgeMatrix")
formals(diagdgeprod) <- alist(x=, y=NULL)
setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"),
diagdgeprod, valueClass = "dgeMatrix")
setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"),
function(x, y) {
dx <- dim(x)
dy <- dim(y)
if(dx[2] != dy[1]) stop("non-matching dimensions")
as(if(y@diag == "U") x else x * rep.int(y@x, dx[1]), "Matrix")
})
setMethod("%*%", signature(x = "dgeMatrix", y = "diagonalMatrix"),
function(x, y) {
dx <- dim(x)
dy <- dim(y)
if(dx[2] != dy[1]) stop("non-matching dimensions")
if(y@diag == "N")
x@x <- x@x * rep.int(y@x, dx[1])
x
})
## crossprod {more of these}
## tcrossprod --- all are not yet there: do the dense ones here:
## FIXME:
## setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "denseMatrix"),
## function(x, y = NULL) {
## })
## setMethod("tcrossprod", signature(x = "denseMatrix", y = "diagonalMatrix"),
## function(x, y = NULL) {
## })
### ---------------- diagonal o sparse -----------------------------
## These are cheap implementations via coercion
## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
function(x, y) as(x, "sparseMatrix") %*% y)
setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
function(x, y) x %*% as(y, "sparseMatrix"))
setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
## similar to prTriang() in ./Auxiliaries.R :
prDiag <-
function(x, digits = getOption("digits"), justify = "none", right = TRUE)
{
cf <- array(".", dim = x@Dim, dimnames = x@Dimnames)
cf[row(cf) == col(cf)] <-
sapply(diag(x), format, digits = digits, justify = justify)
print(cf, quote = FALSE, right = right)
invisible(x)
}
setMethod("show", signature(object = "diagonalMatrix"),
function(object) prDiag(object))