library(stats, pos = "package:base", verbose = FALSE)
library(utils, pos = "package:base", verbose = FALSE)
showClass("sparseQR")
set.seed(2)
m <- 300L
n <- 60L
A <- rsparsematrix(m, n, 0.05)
## With dimnames, to see that they are propagated :
dimnames(A) <- dn <- list(paste0("r", seq_len(m)),
paste0("c", seq_len(n)))
(qr.A <- qr(A))
str(e.qr.A <- expand2(qr.A, complete = FALSE), max.level = 2L)
str(E.qr.A <- expand2(qr.A, complete = TRUE), max.level = 2L)
t(sapply(e.qr.A, dim))
t(sapply(E.qr.A, dim))
## Horribly inefficient, but instructive :
slowQ <- function(V, beta) {
d <- dim(V)
Q <- diag(d[1L])
if(d[2L] > 0L) {
for(j in d[2L]:1L) {
cat(j, "\n", sep = "")
Q <- Q - (beta[j] * tcrossprod(V[, j])) %*% Q
}
}
Q
}
ae1 <- function(a, b, ...) all.equal(as(a, "matrix"), as(b, "matrix"), ...)
ae2 <- function(a, b, ...) ae1(unname(a), unname(b), ...)
## A ~ P1' Q R P2' ~ P1' Q1 R1 P2' in floating point
stopifnot(exprs = {
identical(names(e.qr.A), c("P1.", "Q1", "R1", "P2."))
identical(names(E.qr.A), c("P1.", "Q" , "R" , "P2."))
identical(e.qr.A[["P1."]],
new("pMatrix", Dim = c(m, m), Dimnames = c(dn[1L], list(NULL)),
margin = 1L, perm = invertPerm(qr.A@p, 0L, 1L)))
identical(e.qr.A[["P2."]],
new("pMatrix", Dim = c(n, n), Dimnames = c(list(NULL), dn[2L]),
margin = 2L, perm = invertPerm(qr.A@q, 0L, 1L)))
identical(e.qr.A[["R1"]], triu(E.qr.A[["R"]][seq_len(n), ]))
identical(e.qr.A[["Q1"]], E.qr.A[["Q"]][, seq_len(n)] )
identical(E.qr.A[["R"]], qr.A@R)
## ae1(E.qr.A[["Q"]], slowQ(qr.A@V, qr.A@beta))
ae1(crossprod(E.qr.A[["Q"]]), diag(m))
ae1(A, with(e.qr.A, P1. %*% Q1 %*% R1 %*% P2.))
ae1(A, with(E.qr.A, P1. %*% Q %*% R %*% P2.))
ae2(A.perm <- A[qr.A@p + 1L, qr.A@q + 1L], with(e.qr.A, Q1 %*% R1))
ae2(A.perm , with(E.qr.A, Q %*% R ))
})
## More identities
b <- rnorm(m)
stopifnot(exprs = {
ae1(qrX <- qr.X (qr.A ), A)
ae2(qrQ <- qr.Q (qr.A ), with(e.qr.A, P1. %*% Q1))
ae2( qr.R (qr.A ), with(e.qr.A, R1))
ae2(qrc <- qr.coef (qr.A, b), with(e.qr.A, solve(R1 %*% P2., t(qrQ)) %*% b))
ae2(qrf <- qr.fitted(qr.A, b), with(e.qr.A, tcrossprod(qrQ) %*% b))
ae2(qrr <- qr.resid (qr.A, b), b - qrf)
ae2(qrq <- qr.qy (qr.A, b), with(E.qr.A, P1. %*% Q %*% b))
ae2(qr.qty(qr.A, qrq), b)
})
## Sparse and dense computations should agree here
qr.Am <- qr(as(A, "matrix")) # <=> qr.default(A)
stopifnot(exprs = {
ae2(qrX, qr.X (qr.Am ))
ae2(qrc, qr.coef (qr.Am, b))
ae2(qrf, qr.fitted(qr.Am, b))
ae2(qrr, qr.resid (qr.Am, b))
})
Run the code above in your browser using DataLab