Nothing
### Testing the group methods --- some also happens in ./Class+Meth.R
## for R_DEFAULT_PACKAGES=NULL :
library(stats)
library(utils)
library(Matrix)
source(system.file("test-tools.R", package = "Matrix"))# identical3() etc
assertErrV <- function(e) tools::assertError(e, verbose=TRUE)
cat("doExtras:",doExtras,"\n")
options(nwarnings = 1e4)
set.seed(2001)
mm <- Matrix(rnorm(50 * 7), ncol = 7)
xpx <- crossprod(mm)# -> "factors" in mm !
round(xpx, 3) # works via "Math2"
y <- rnorm(nrow(mm))
xpy <- crossprod(mm, y)
res <- solve(xpx, xpy)
signif(res, 4) # 7 x 1 Matrix
stopifnot(all(signif(res) == signif(res, 6)),
all(round (xpx) == round (xpx, 0)))
## exp(): component wise
signif(dd <- (expm(xpx) - exp(xpx)) / 1e34, 3)# 7 x 7
validObject(xpx)
validObject(xpy)
validObject(dd)
## "Math" also, for log() and [l]gamma() which need special treatment
stopifnot(exprs = {
identical(exp(res)@x, exp(res@x))
identical(log(abs(res))@x, log(abs((res@x))))
identical(lgamma(res)@x, lgamma(res@x))
})
## "Arith" / "Ops"
M <- Matrix(1:12, 4,3)
m <- cbind(4:1)
stopifnot(exprs = {
identical(M*m, M*c(m)) # M*m failed in Matrix_1.3-3 pre-release:
identical(m*M, c(m)*M)
## M*m: Error in eval(....) : object 'x1' not found
isValid(M1 <- M[, 1, drop=FALSE], "dgeMatrix")
identical(M*M1, M*M1[,1]) # M*M1 failed ..
identical(M-M1, M-M1[,1])
identical(M/M1, M/M1[,1])
identical(M1*M, M1[,1]*M)
identical(M1-M, M1[,1]-M)
identical(M1/M, M1[,1]/M)
})
###--- sparse matrices ---------
mC <- Matrix(c(0, 0, 2:0), 3, 5)
sm <- sin(mC)
stopifnot(class(sm) == class(mC), class(mC) == class(mC^2),
dim(sm) == dim(mC),
class(0 + 100*mC) == class(mC),
all.equal(0.1 * ((0 + 100*mC)/10), mC),
all.equal(sqrt(mC ^ 2), mC),
identical(mC^2, mC * mC),
identical(mC*2, mC + mC)
)
x <- Matrix(rbind(0,cbind(0, 0:3,0,0,-1:2,0),0))
x # sparse
(x2 <- x + 10*t(x))
stopifnot(is(x2, "sparseMatrix"),
identical(x2, t(x*10 + t(x))),
identical(x, as((x + 10) - 10, "CsparseMatrix")))
(px <- Matrix(x^x - 1))#-> sparse again
stopifnot(px@i == c(3,4,1,4),
px@x == c(3,26,-2,3))
## From: "Florent D." .. Thu, 23 Feb 2012 -- bug report
##---> MM: Make a regression test:
tst <- function(n, i = 1) {
stopifnot(i >= 1, n >= i)
D <- .sparseDiagonal(n)
ee <- numeric(n) ; ee[i] <- 1
stopifnot(all(D - ee == diag(n) - ee),
all(D * ee == diag(n) * ee),
all(ee - D == ee - diag(n)),
{C <- (ee / D == ee / diag(n)); all(is.na(C) | C)},
TRUE)
}
nn <- if(doExtras) 27 else 7
tmp <- sapply(1:nn, tst) # failed in Matrix 1.0-4
i <- sapply(1:nn, function(i) sample(i,1))
tmp <- mapply(tst, n= 1:nn, i= i)# failed too
(lsy <- new("lsyMatrix", Dim = c(2L,2L), x=c(TRUE,FALSE,TRUE,TRUE)))
nsy <- as(lsy, "nMatrix")
(t1 <- new("ltrMatrix", Dim = c(1L,1L), x = TRUE))
(t2 <- new("ltrMatrix", Dim = c(2L,2L), x = rep(TRUE,4)))
stopifnot(all(lsy), # failed in Matrix 1.0-4
all(nsy), # dito
all(t1), # "
## ok previously (all following):
!all(t2),
all(sqrt(lsy) == 1))
dsy <- lsy+1
D3 <- Diagonal(x=4:2); L7 <- Diagonal(7) > 0
validObject(xpp <- pack(round(xpx,2)))
lsp <- xpp > 0
(dsyU <- .diag2dense(D3, ".", "s"))
lsyU <- .diag2dense(Diagonal(5) > 0, ".", "s")
str(lsyU)
stopifnot({
isValid(dsyU, "dsyMatrix") && dsyU@uplo == "U"
isValid(dsyL <- t(dsyU), "dsyMatrix") && dsyL@uplo == "L"
isValid(dspU <- pack(dsyU), "dspMatrix") && dspU@uplo == "U"
isValid(dspL <- pack(dsyL), "dspMatrix") && dspL@uplo == "L"
identical(dspU, t(dspL))
isValid(lsyU, "lsyMatrix") && lsyU@uplo == "U"
isValid(lsyL <- t(lsyU), "lsyMatrix") && lsyL@uplo == "L"
isValid(lspU <- pack(lsyU), "lspMatrix") && lspU@uplo == "U"
isValid(lspL <- pack(lsyL), "lspMatrix") && lspL@uplo == "L"
identical(lspL, t(lspU))
##
## log(x, <base>) -- was mostly *wrong* upto 2019-10 [Matrix <= 1.2-17]
all.equal(log(abs(dsy), 2), log2(abs(dsy)))
all.equal(log(abs(dsyL),2), log2(abs(dsyL)))
all.equal(log(abs(dspU),2), log2(abs(dspU)))
all.equal(log(abs(dspL),2), log2(abs(dspL)))
## These always worked, as {0,1} -> {-Inf,0} independent of 'base':
all.equal(log(abs(lsy), 2), log2(abs(lsy)))
all.equal(log(abs(lsyL),2), log2(abs(lsyL)))
all.equal(log(abs(lspU),2), log2(abs(lspU)))
all.equal(log(abs(lspL),2), log2(abs(lspL)))
##
all.equal(log(abs(res), 2), log2(abs(res)))
all.equal(log(abs(xpy), 2), log2(abs(xpy)))
all.equal(log(abs(xpp), 2), log2(abs(xpp)))
all.equal(log(abs( D3), 2), log2(abs( D3)))
all.equal(log(abs( L7), 2), log2(abs( L7)))
})
showProc.time()
## is.finite() -- notably for symmetric packed / uplo="L" with NA :
spU <- new("dspMatrix", Dim = c(3L, 3L), x = c(0, NA, 0, NA, NA, 0), uplo = "U")
sU <- new("dsyMatrix", Dim = c(3L, 3L), x = c(1, NA, NA, NA, 1, NA, 8, 2, 1), uplo = "U")
sL <- t(sU)
spL <- t(spU)
trU <- triu(spU)
trL <- tril(spL)
stopifnot(exprs = {
spL@uplo == "L"
trU@uplo == "U"
trL@uplo == "L"
identical(trU, triu(spL))
identical(trL, tril(spU))
})
isU <- is.finite(sU)
isL <- is.finite(sL)
stopifnot(exprs = {
identical(isU, t(isL))
all(isU == isL)
which(!isU, arr.ind = TRUE) == c(2:1, 1:2)
})
isFu <- is.finite(spU)
isFl <- is.finite(spL)
isFtu <- is.finite(trU)
isFtl <- is.finite(trL)
stopifnot(exprs = {
all(isFu == diag(TRUE, 3))
all(isFu == isFl) # has failed till 2022-06-11
isTriangular(isFtu)
isTriangular(isFtl)
identical(rep(TRUE, 6), pack(tril(isFtu))@x)
identical(rep(TRUE, 6), pack(triu(isFtl))@x)
})
showProc.time()
set.seed(111)
local({
for(i in 1:(if(doExtras) 20 else 5)) {
M <- rspMat(n=1000, 200, density = 1/20)
v <- rnorm(ncol(M))
m <- as(M,"matrix")
stopifnot(all(t(M)/v == t(m)/v))
cat(".")
}});cat("\n")
## Now just once, with a large such matrix:
local({
n <- 100000; m <- 30000
AA <- rspMat(n, m, density = 1/20000)
v <- rnorm(m)
st <- system.time({
BB <- t(AA)/v # should happen *fast*
stopifnot(dim(BB) == c(m,n), is(BB, "sparseMatrix"))
})
str(BB)
print(st)
if(Sys.info()[["sysname"]] == "Linux") {
mips <- try(as.numeric(sub(".*: *", '',
grep("bogomips", readLines("/proc/cpuinfo"),
ignore.case=TRUE, # e.g. ARM : "BogoMIPS"
value=TRUE)[[1]])))
print(mips)
if(is.numeric(mips) && all(mips) > 0 && doExtras)
# doExtras: valgrind (2023-07-26) gave large 'st[1]'
stopifnot(st[1] < 1000/mips)# ensure there was no gross inefficiency
}
})
###----- Compare methods ---> logical Matrices ------------
l3 <- upper.tri(matrix(, 3, 3))
(ll3 <- Matrix(l3))
dt3 <- (99* Diagonal(3) + (10 * ll3 + Diagonal(3)))/10
(dsc <- crossprod(ll3))
stopifnot(identical(ll3, t(t(ll3))),
identical(dsc, t(t(dsc))))
stopifnotValid(ll3, "ltCMatrix")
stopifnotValid(dsc, "dsCMatrix")
stopifnotValid(dsc + 3 * Diagonal(nrow(dsc)), "dsCMatrix")
stopifnotValid(dt3, "triangularMatrix") # remained triangular
stopifnotValid(dt3 > 0, "triangularMatrix")# ditto
(lm1 <- dsc >= 1) # now ok
(lm2 <- dsc == 1) # now ok
nm1 <- as(lm1, "nMatrix")
(nm2 <- as(lm2, "nMatrix"))
stopifnot(validObject(lm1), validObject(lm2),
validObject(nm1), validObject(nm2),
identical(dsc, dsc * as(lm1, "dMatrix")))
crossprod(lm1) # lm1: "lsC*"
cnm1 <- crossprod(nm1, boolArith = FALSE)
stopifnot(is(cnm1, "symmetricMatrix"), ## whereas the %*% is not:
Q.eq(cnm1, nm1 %*% nm1))
dn1 <- as(nm1, "denseMatrix")
stopifnot(all(dn1 == nm1))
dsc[2,3] <- NA ## now has an NA (and no longer is symmetric)
## ----- and "everything" is different
## also add "non-structural 0":
dsc@x[1] <- 0
dsc
dsc/ 5
dsc + dsc
dsc - dsc
dsc + 1 # -> no longer sparse
Tsc <- as(dsc, "TsparseMatrix")
dsc. <- drop0(dsc)
stopifnot(Q.eq(dsc., Matrix((dsc + 1) - 1)),
identical(as(-Tsc,"CsparseMatrix"), (-1) * Tsc),
identical(-dsc., (-1) * dsc.),
identical3(-Diagonal(3), Diagonal(3, -1), (-1) * Diagonal(3)),
Q.eq(dsc., Matrix((Tsc + 1) -1)), # ok (exact arithmetic)
Q.eq(0 != dsc, dsc != Matrix(0, 3, 3)),
Q.eq(0 != dsc, dsc != c(0,0)) # with a warning ("not multiple ..")
)
str(lm1 <- dsc >= 1) # now ok (NA in proper place, however:
lm1 ## NA used to print as ' ' , now 'N'
(lm2 <- dsc == 1)# ditto
stopifnot(identical(crossprod(lm1),# "lgC": here works!
crossprod(as(lm1, "dMatrix"))),
identical(lm2, lm1 & lm2),
identical(lm1, lm1 | lm2))
ddsc <- kronecker(Diagonal(7), dsc)
isValid(ddv <- rowSums(ddsc, sparseResult=TRUE), "sparseVector")
sv <- colSums(kC <- kronecker(mC,kronecker(mC,mC)), sparseResult=TRUE)
EQ <- ddv == rowSums(ddsc)
na.ddv <- is.na(ddv)
sM <- Matrix(pmax(0, round(rnorm(50*15, -1.5), 2)), 50,15)
stopifnot(sv == colSums(kC), is.na(as.vector(ddv)) == na.ddv,
isValid(sM/(-7:7), "CsparseMatrix"),
all(EQ | na.ddv))
## Subclasses (!)
setClass("m.spV", contains = "dsparseVector")
(m.ddv <- as(ddv, "m.spV"))
stopifnot(all.equal(m.ddv, ddv, check.class = FALSE))# failed
setClass("m.dgC", contains = "dgCMatrix")
(m.mC <- as(mC, "m.dgC"))
stopifnot(all(m.mC == mC))
## 2-level inheritance (R-forge Matrix bug #6185)
## https://r-forge.r-project.org/tracker/index.php?func=detail&aid=6185&group_id=61&atid=294
setClass("Z", representation(zz = "list"))
setClass("C", contains = c("Z", "dgCMatrix"))
setClass("C2", contains = "C")
setClass("C3", contains = "C2")
(cc <- as(mC, "C"))
c2 <- as(mC, "C2")
c3 <- as(mC, "C3")
# as(*, "matrix") of these __fail__ in R < 3.5.0
# before R_check_class_and_super() became better :
print(c2)
print(c3)
## ==> Error in asMethod(object) : invalid class of object to as_cholmod_sparse
stopifnot(identical(cc > 0, mC > 0 -> m.gt.0), ## cc > 0 - gave error in Matrix <= 1.2-11
identical(c2 > 0, m.gt.0),
identical(c3 > 0, m.gt.0))
## Just for print "show":
z <- round(rnorm(77), 2)
z[sample(77,10)] <- NA
(D <- Matrix(z, 7)) # dense
z[sample(77,15)] <- 0
(D <- Matrix(z, 7)) # sparse
abs(D) >= 0.5 # logical sparse
## For the checks below, remove some and add a few more objects:
rm(list= ls(pattern="^.[mMC]?$"))
T3 <- Diagonal(3) > 0; stopifnot(T3@diag == "U") # "uni-diagonal"
validObject(dtp <- pack(as(dt3, "denseMatrix")))
stopifnot(exprs = {
isValid(lsC <- as(lsp, "CsparseMatrix"), "lsCMatrix")
## 0-extent matrices {fixes in Feb.2019}:
isValid(L00 <- L7[FALSE,FALSE], "ldiMatrix")
isValid(x60 <- x2[,FALSE], "dgCMatrix")
identical(t(x60), x06 <- x2[FALSE,])
isValid(x00 <- x06[,FALSE], "dgCMatrix")
isValid(sv0 <- as(x06, "sparseVector"), "dsparseVector")
})
showProc.time()
### Consider "all" Matrix classes
cl <- sapply(ls(), function(.) class(get(.)))
Mcl <- cl[vapply(cl, extends, "Matrix", FUN.VALUE=NA) |
vapply(cl, extends, "sparseVector", FUN.VALUE=NA)]
table(Mcl)
## choose *one* of each class:
## M.objs <- names(Mcl[!duplicated(Mcl)])
## choose all
M.objs <- names(Mcl) # == the ls() from above
Mat.objs <- M.objs[vapply(M.objs, function(nm) is(get(nm), "Matrix"), NA)]
MatDims <- t(vapply(Mat.objs, function(nm) dim(get(nm)), 0:1))
## Nice summary info :
noquote(cbind(Mcl[Mat.objs], format(MatDims)))
## dtCMatrix, uplo="L" :
(CtL <- t(as(Diagonal(x=4:2), "CsparseMatrix")))
m2 <- cbind(c(0, NA, NA),
c(0, 0, NA), 0)
op <- options(Matrix.verbose = 2)
r <- CtL > m2 # failed in Matrix <= 1.4-1, with
## Compare <Csparse> -- "dtCMatrix" > "dtCMatrix" :
stopifnot(identical(is.na(m2), unname(as.matrix(is.na(r)))), diag(r), isDiagonal(triu(r)))
M <- new("dtCMatrix", i = c(0L, 0:1, 0:2), p = c(0:1, 3L, 6L),
x = c(10,1, 10,1, 1,10), Dim = c(3L, 3L), uplo = "U")
m2 <- matrix(c(0, NA, NA, 0, 0, NA, 0, 0, 0), 3)
r <- M & m2 # failed in Matrix <= 1.4-1
assert.EQ.mat(M | m2 -> ro,
as.mat(M)| m2, tol=0)
D4 <- Diagonal(x=0+ 4:2)
rd <- D4 | m2 # gave invalid class "ltTMatrix" object: uplo='U' must not have sparse entries below the diagonal
M2 <- Matrix(m2); T2 <- Matrix:::.diag2T.smart(D4, M2, kind="l")
stopifnot(exprs = {
all(!r)
## fix in .do.Logic.lsparse() {needed uplo="L"}
identical(rd, T2 | M2)
identical(rd, as(T2, "CsparseMatrix") | as(M2, "lMatrix"))
})
options(op)
if(doExtras || interactive()) { # save testing time
### Systematically look at all "Ops" group generics for "all" Matrix classes
### -------------- Main issue: Detect infinite recursion problems
mDims <- MatDims %*% (d.sig <- c(1, 1000)) # "dim-signature" to match against
m2num <- function(m) { if(is.integer(m)) storage.mode(m) <- "double" ; m }
M.knd <- Matrix:::.M.kind
cat("Checking all Ops group generics for a set of arguments:\n",
"-------------------------------------------------------\n", sep='')
op <- options(warn = 2)#, error=recover)
for(gr in getGroupMembers("Ops")) {
cat(gr,"\n",paste(rep.int("=",nchar(gr)),collapse=""),"\n", sep='')
v0 <- if(gr == "Arith") numeric() else logical()
for(f in getGroupMembers(gr)) {
line <- strrep("-", nchar(f) + 2)
cat(sprintf("%s\n%s :\n%s\n", line, dQuote(f), line))
for(nm in M.objs) {
if(doExtras) cat(" '",nm,"' ", sep="")
M <- get(nm, inherits=FALSE)
n.m <- NROW(M)
cat("o")
for(x in list(TRUE, -3.2, 0L, seq_len(n.m))) {
cat(".")
validObject(r1 <- do.call(f, list(M,x)))
validObject(r2 <- do.call(f, list(x,M)))
stopifnot(dim(r1) == dim(M), dim(r2) == dim(M),
allow.logical0 = TRUE)
}
## M o 0-length === M :
validObject(M0. <- do.call(f, list(M, numeric())))
validObject(.M0 <- do.call(f, list(numeric(), M)))
if(length(M)) # <non-0-extent M> o <0-length v> == 0-length v
stopifnot(identical(M0., v0), identical(.M0, v0))
else if(is(M, "Matrix"))
stopifnot(identical(M0., as(M, if(gr == "Arith") "dMatrix" else "lMatrix")),
identical(M0., .M0))
else # if(is(M, "sparseVector")) of length 0
stopifnot(identical(M0., v0), identical(.M0, v0))
## M o <sparseVector>
x <- numeric(n.m)
if(length(x)) x[c(1,length(x))] <- 1:2
sv <- as(x, "sparseVector")
cat("s.")
validObject(r3 <- do.call(f, list(M, sv)))
stopifnot(identical(dim(r3), dim(M)))
if(doExtras && is(M, "Matrix")) { ## M o <Matrix>
d <- dim(M)
ds <- sum(d * d.sig) # signature .. match with all other sigs
match. <- ds == mDims # (matches at least itself)
cat("\nM o M:")
for(oM in Mat.objs[match.]) {
M2 <- get(oM)
## R4 := M f M2
validObject(R4 <- do.call(f, list(M, M2)))
cat(".")
for(M. in list(as.mat(M), M)) { ## two cases ..
r4 <- m2num(as.mat(do.call(f, list(M., as.mat(M2)))))
cat(",")
if(!identical(r4, as.mat(R4))) {
cat(sprintf("\n %s %s %s gave not identical r4 & R4:\n",
nm, f, oM)); print(r4); print(R4)
C1 <- (eq <- R4 == r4) | (N4 <- as.logical((nr4 <- is.na(eq)) & !is.finite(R4)))
if(isTRUE(all(C1)) || isTRUE(all.equal(as.mat(R4), r4,
tolerance = 1e-14)))
cat(sprintf(
" --> %s %s %s (ok): only difference is %s (matrix) and %s (Matrix)\n",
M.knd(M), f, M.knd(M2)
, paste(vapply(unique(r4[N4]), format, ""), collapse="/")
, paste(vapply(unique(R4[N4]), format, ""), collapse="/")
))
else if(isTRUE(all(eq | (nr4 & Matrix:::is0(R4)))))
cat(" --> 'ok': only difference is 'NA' (matrix) and 0 (Matrix)\n")
else stop("R4 & r4 differ \"too much\"")
}
}
cat("i")
}
}
}
cat("\n")
}
}
if(length(warnings())) print(summary(warnings()))
showProc.time()
options(op) # reset 'warn'
} # doExtras
###---- Now checking 0-length / 0-dim cases <==> to R >= 3.4.0 !
## arithmetic, logic, and comparison (relop) for 0-extent arrays
(m <- Matrix(cbind(a=1[0], b=2[0])))
Lm <- as(m, "lMatrix")
## Im <- as(m, "iMatrix")
stopifnot(
identical(m, m + 1), identical(m, m + 1[0]),
identical(m, m + NULL),## now (2016-09-27) ok
identical(m, Lm+ 1L) ,
identical(m, m+2:3), ## gave error "length does not match dimension"
identical(Lm, m & 1),
identical(Lm, m | 2:3),## had Warning "In .... : data length exceeds size of matrix"
identical(Lm, m & TRUE[0]),
identical(Lm, m | FALSE[0]),
identical(Lm, m > NULL),
identical(Lm, m > 1),
identical(Lm, m > .1[0]),## was losing dimnames
identical(Lm, m > NULL), ## was not-yet-implemented
identical(Lm, m <= 2:3) ## had "wrong" warning
)
mm <- m[,c(1:2,2:1,2)]
assertErrV(m + mm) # ... non-conformable arrays
assertErrV(m | mm) # ... non-conformable arrays
## Matrix: ok ; R : ok, in R >= 3.4.0
assertErrV(m == mm)
## in R <= 3.3.x, relop returned logical(0) and m + 2:3 returned numeric(0)
##
## arithmetic, logic, and comparison (relop) -- inconsistency for 1x1 array o <vector >= 2>:
## FIXME: desired errors are _not_ thrown for ddiMatrix (when doDiag=TRUE)
(m1 <- Matrix(1, 1L, 1L, dimnames = list("Ro", "col"), doDiag = FALSE))
## col
## Ro 1
## Before Sep.2016, here, Matrix was the *CONTRARY* to R:
assertErrV(m1 + 1:2)## M.: "correct" ERROR // R 3.4.0: "deprecated" warning (--> will be error)
assertErrV(m1 & 1:2)## gave 1 x 1 [TRUE] -- now Error, as R
assertErrV(m1 <= 1:2)## gave 1 x 1 [TRUE] -- now Error, as R
assertErrV(m1 & 1:2)## gave 1 x 1 [TRUE] -- now Error, as R
assertErrV(m1 <= 1:2)## gave 1 x 1 [TRUE] -- now Error, as R
##
## arrays combined with NULL works now
stopifnot(identical(Matrix(3,1,1) + NULL, 3[0]))
stopifnot(identical(Matrix(3,1,1) > NULL, T[0]))
stopifnot(identical(Matrix(3,1,1) & NULL, T[0]))
## in R >= 3.4.0: logical(0) # with *no* warning and that's correct!
if(doExtras || interactive()) { # save testing time
mStop <- function(...) stop(..., call. = FALSE)
##
cat("Checking the Math (+ Math2) group generics for a set of arguments:\n",
"------------ ==== ------------------------------------------------\n", sep='')
doStop <- function() mStop("**Math: ", f,"(<",class(M),">) of 'wrong' class ", dQuote(class(R)))
mM <- getGroupMembers("Math")
mM2 <- getGroupMembers("Math2")
(mVec <- grep("^cum", mM, value=TRUE)) ## <<- are special: return *vector* for matrix input
for(f in c(mM, mM2)) {
cat(sprintf("%-9s :\n %-7s\n", paste0('"',f,'"'), paste(rep("-", nchar(f)), collapse="")))
givesVec <- f %in% mVec
fn <- get(f)
if(f %in% mM2) { fn0 <- fn ; fn <- function(x) fn0(x, digits=3) }
for(nm in M.objs) {
M <- get(nm, inherits=FALSE)
is.m <- length(dim(M)) == 2
cat(" '",nm,"':", if(is.m) "m" else "v", sep="")
R <- fn(M)
r <- fn(m <- if(is.m) as.mat(M) else as.vector(M))
stopifnot(identical(dim(R), dim(r)))
if(givesVec || !is.m) {
assert.EQ(R, r, check.class = FALSE)
} else { ## (almost always:) matrix result
assert.EQ.mat(R, r, check.class = FALSE)
## check preservation of properties, notably super class
if(prod(dim(M)) > 1 && is(M, "diagonalMatrix" ) && isDiagonal(R) && !is(R, "diagonalMatrix" )) doStop()
if(prod(dim(M)) > 1 && is(M, "triangularMatrix") && (iT <- isTriangular(R)) && attr(iT, "kind") == M@uplo &&
!is(R, "triangularMatrix")) doStop()
}
}
cat("\n")
}
showProc.time()
##
cat("Checking the Summary group generics for a set of arguments:\n",
"------------ ======= ------------------------------------------------\n", sep='')
for(f in getGroupMembers("Summary")) {
cat(sprintf("%-9s :\n %-7s\n", paste0('"',f,'"'), paste(rep("-", nchar(f)), collapse="")))
givesVec <- f %in% mVec
fn <- get(f)
if(f %in% mM2) { fn0 <- fn ; fn <- function(x) fn0(x, digits=3) }
for(nm in M.objs) {
M <- get(nm, inherits=FALSE)
is.m <- length(dim(M)) == 2
cat(" '",nm,"':", if(is.m) "m" else "v", sep="")
R <- fn(M)
r <- fn(m <- if(is.m) as.mat(M) else as.vector(M))
stopifnot(identical(dim(R), dim(r)))
assert.EQ(R, r)
}
cat("\n")
if(length(warnings())) print(summary(warnings()))
}
} # doExtras
## <Math>(x) behaved incorrectly in Matrix <= 1.4-1
## for unit diagonal 'x' when f(0) == 0 and f(1) != 1
Dn <- list(c("a", "b"), c("A", "B"))
udi <- new("ddiMatrix", Dim = c(2L, 2L), Dimnames = Dn, diag = "U")
utC <- new("dtCMatrix", Dim = c(2L, 2L), Dimnames = Dn, diag = "U",
p = integer(3L))
utr <- new("dtrMatrix", Dim = c(2L, 2L), Dimnames = Dn, diag = "U",
x = double(4L))
sinu <- `dimnames<-`(sin(diag(2L)), Dn)
for(u in list(udi, utC, utr))
stopifnot(identical(as(sin(u), "matrix"), sinu))
## Originally in ../man/all-methods.Rd :
M <- Matrix(1:12 +0, 3,4)
all(M >= 1) # TRUE
any(M < 0 ) # FALSE
MN <- M; MN[2,3] <- NA; MN
all(MN >= 0) # NA
any(MN < 0) # NA
any(MN < 0, na.rm = TRUE) # -> FALSE
sM <- as(MN, "sparseMatrix")
stopifnot(all(M >= 1), !any(M < 0),
all.equal((sM >= 1), as(MN >= 1, "sparseMatrix")),
## MN:
any(MN < 2), !all(MN < 5),
is.na(all(MN >= 0)), is.na(any(MN < 0)),
all(MN >= 0, na.rm=TRUE), !any(MN < 0, na.rm=TRUE),
## same for sM :
any(sM < 2), !all(sM < 5),
is.na(all(sM >= 0)), is.na(any(sM < 0)),
all(sM >= 0, na.rm=TRUE), !any(sM < 0, na.rm=TRUE)
)
## prod(<symmetricMatrix>) does not perform multiplies in row/column order :
x4 <- new("dspMatrix", Dim = c(4L, 4L),
x = c(171, 53, 79, 205, 100, 285, 98, 15, 99, 84))
p4 <- prod( x4)
p4. <- prod(as(x4, "generalMatrix"))
p4.. <- prod(as(x4, "matrix"))
stopifnot(all.equal(p4, p4. , tolerance = 1e-15),
all.equal(p4., p4.., tolerance = 1e-15))
all.equal(p4, p4. , tolerance = 0)
all.equal(p4., p4.., tolerance = 0)
.Machine[["sizeof.longdouble"]]
cat('Time elapsed: ', proc.time(),'\n') # for ``statistical reasons''
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.