tests/validObj.R

In Matrix: Sparse and Dense Matrix Classes and Methods

library(Matrix)
### Do all kinds of object creation and coercion

source(system.file("test-tools.R", package = "Matrix"))

.drop.factors <- function(x, check = FALSE)
    `slot<-`(x, "factors", check = check, value = list())

## the empty ones:
checkMatrix(new("dgeMatrix"))
checkMatrix(Matrix(,0,0))

## "dge"
assertError( new("dgeMatrix", Dim = c(2,2), x= 1:4) )# double 'Dim'
assertError( new("dgeMatrix", Dim = as.integer(c(2,2)), x= 1:4) )# int 'x'
assertError( new("dgeMatrix", Dim = 2:2, x=as.double(1:4)) )# length(Dim) !=2
assertError( new("dgeMatrix", Dim = as.integer(c(2,2)), x= as.double(1:5)))

checkMatrix(m1 <- Matrix(1:6, ncol=2))
checkMatrix(m2 <- Matrix(1:7 +0, ncol=3)) # a (desired) warning
c("dgeMatrix", "ddenseMatrix", "generalMatrix", "dMatrix",
  "denseMatrix", "compMatrix", "Matrix") -> m1.cl
stopifnot(!anyNA(match(m1.cl, is(m1))),
	  dim(t(m1)) == 2:3, identical(m1, t(t(m1))))
c.nam <- paste("C",1:2, sep='')
dimnames(m1) <- list(NULL, c.nam)
checkMatrix(m1) # failed in 0.999375-10
checkMatrix(tm1 <- t(m1))
stopifnot(colnames(m1) == c.nam,
	  identical(dimnames(tm1), list(c.nam, NULL)),
	  identical(m1, t(tm1)))

## an example of *named* dimnames
(t34N <- as(unclass(table(x = gl(3,4), y=gl(4,3))), "unpackedMatrix"))
stopifnot(identical(dimnames(t34N),
		    dimnames(as(t34N, "matrix"))),
          identical(t34N, t(t(t34N))))

## "dpo"
checkMatrix(cm <- crossprod(m1))
checkMatrix(cp <- as(cm, "packedMatrix"))# 'dpp' + factors
checkMatrix(cs <- as(cm, "dsyMatrix"))# 'dsy' + factors
checkMatrix(dcm <- as(cm, "generalMatrix"))#'dge'
checkMatrix(mcm <- as(cm, "dMatrix")) # 'dsy' + factors -- buglet? rather == cm?
checkMatrix(mc. <- as(cm, "Matrix"))  # dpo --> dsy -- (as above)  FIXME? ??
stopifnot(identical(mc., mcm),
	  identical(.drop.factors(cm), (2*cm)/2),# remains dpo
	  identical(cm + cp, cp + cs),# dge
	  identical(mc., mcm),
	  all(2*cm == mcm * 2))

checkMatrix(eq <- cm == cs)
stopifnot(all(eq@x),
	  identical3(pack(eq), cs == cp, cm == cp),
	  as.logical(!(cs < cp)),
	  identical4(!(cs < cp), !(cp > cs), cp <= cs, cs >= cp))

## Coercion to 'dpo' should give an error if result would be invalid
M <- Matrix(diag(4) - 1)
assertError(as(M, "dpoMatrix"))
M. <- as(M, "generalMatrix")
M.[1,2] <- 10 # -> not even symmetric anymore
assertError(as(M., "dpoMatrix"))


## Cholesky
checkMatrix(ch <- chol(cm))
checkMatrix(ch2 <- chol(as(cm, "dsyMatrix")))
checkMatrix(ch3 <- chol(as(cm, "generalMatrix")))
stopifnot(is.all.equal3(as(ch, "matrix"), as(ch2, "matrix"), as(ch3, "matrix")))
### Very basic	triangular matrix stuff

assertError( new("dtrMatrix", Dim = c(2,2), x= 1:4) )# double 'Dim'
assertError( new("dtrMatrix", Dim = as.integer(c(2,2)), x= 1:4) )# int 'x'
## This caused a segfault (before revision r1172 in ../src/dtrMatrix.c):
assertError( new("dtrMatrix", Dim = 2:2, x=as.double(1:4)) )# length(Dim) !=2
assertError( new("dtrMatrix", Dim = as.integer(c(2,2)), x= as.double(1:5)))

tr22 <- new("dtrMatrix", Dim = as.integer(c(2,2)), x=as.double(1:4))
tt22 <- t(tr22)
(tPt <- tr22 + tt22)
stopifnot(identical(10 * tPt, tPt * 10),
	  as.vector(t.22 <- (tr22 / .5)* .5) == c(1,0,3,4),
	  TRUE) ## not yet: class(t.22) == "dtrMatrix")

## non-square triagonal Matrices --- are forbidden ---
assertError(new("dtrMatrix", Dim = 2:3,
		x=as.double(1:6), uplo="L", diag="U"))

n <- 3:3
assertError(new("dtCMatrix", Dim = c(n,n), diag = "U"))
validObject(T <- new("dtTMatrix", Dim = c(n,n), diag = "U"))
validObject(M <- new("dtCMatrix", Dim = c(n,n), diag = "U",
		     p = rep.int(0:0, n+1)))
stopifnot(identical(as.mat(T), diag(n)))

suppressWarnings(RNGversion("3.5.0")); set.seed(3)
(p9 <- p9. <- as(sample(9), "pMatrix"))
(np9 <- np9. <- as(p9, "TsparseMatrix"))
p9.[1,1] <- np9.[1,1] <- TRUE
stopifnot(is.logical(p9[1,]),
	  is(p9[2,, drop=FALSE], "indMatrix"),
	  is(p9[9:1,], "indMatrix"),
	  isTRUE(p9[-c(1:6, 8:9), 1]),
	  identical(t(p9), solve(p9)),
	  identical(p9[TRUE, ], p9),
          identical(p9[, TRUE], p9),
          identical(p9., np9.),
	  identical(as(diag(9), "pMatrix"), as(1:9, "pMatrix"))
	  )
assert.EQ.mat(p9[TRUE,], as.matrix(np9))

## validObject --> Cparse_validate(.)
mm <- new("dgCMatrix", Dim = c(3L, 5L),
          i = c(2L, 0L, 1L, 2L, 0L, 1L),
          x = c( 2,  1,  1,  2,  1,  2),
          p = c(0:2, 4L, 4L, 6L))

## Previously unsorted columns were sorted - now are flagged as invalid
m. <- mm
ip <- c(1:2, 4:3, 6:5) # permute the 'i' and 'x' slot just "inside column":
m.@i <- m.i <- mm@i[ip]
m.@x <- m.x <- mm@x[ip]
stopifnot(identical(1L, grep("not increasing within columns",
                             validObject(m., test = TRUE))))
.validateCsparse(m., TRUE) # don't use this at home, boys!
m. # now is fixed

## Make sure that validObject() objects...
## 1) to wrong 'p'
m. <- mm; m.@p[1] <- 1L
stopifnot(identical(1L, grep("first element of 'p' slot",
                             validObject(m., test = TRUE))))
m.@p <- mm@p[c(1,3:2,4:6)]
stopifnot(identical(1L, grep("not nondecreasing",
                             validObject(m., test = TRUE))))
## 2) to non-strictly increasing i's:
m. <- mm ; ix <- c(1:3,3,5:6)
m.@i <- mm@i[ix]
m.@x <- mm@x[ix]
stopifnot(identical(1L, grep("not increasing within columns",
                             validObject(m., test = TRUE))))
## ix <- c(1:3, 3:6) # now the the (i,x) slots are too large (and decreasing at end)
## m.@i <- mm@i[ix]
## m.@x <- mm@x[ix]
## stopifnot(identical(grep("^slot i is not.* increasing .*sort",
##                          (msg <- validObject(m., test=TRUE))),# seg.fault in the past
##                     1L))

## over-allocation of the i- and x- slot should be allowed:
## (though it does not really help in M[.,.] <- *  yet)
m. <- mm
m.@i <- c(mm@i, NA, NA, NA)
m.@x <- c(mm@x, 10:12)
validObject(m.)
m. # show() now works
stopifnot(all(m. == mm), # in spite of
	  length(m.@i) > length(mm@i),
          identical(t(t(m.)), mm),
	  identical3(m. * m., m. * mm, mm * mm))
m.[1,4] <- 99 ## FIXME: warning and cuts (!) the over-allocated slots

## Low-level construction of invalid object:
##  Ensure that it does *NOT* segfault
foo <- new("ngCMatrix",
           i = as.integer(c(12204, 16799, 16799, 33517, 1128, 11930, 1128, 11930, 32183)),
           p = rep(0:9, c(2,4,1,11,10,0,1,0,9,12)),
           Dim = c(36952L, 49L))
validObject(foo)# TRUE
foo@i[5] <- foo@i[5] + 50000L
msg <- validObject(foo, test=TRUE)# is -- correctly -- *not* valid anymore
stopifnot(is.character(msg))
## Error in validObject(foo) :
##   invalid class "ngCMatrix" object: all row indices must be between 0 and nrow-1
getLastMsg <- function(tryRes) {
    ## Extract "final" message from erronous try result
    sub("\n$", "", sub("^.*: ", "", as.character(tryRes)))
}
t1 <- try(show(foo)) # error
t2 <- try(head(foo)) # error, but previously a segfault
stopifnot(identical(msg, getLastMsg(t1)),
          identical(msg, getLastMsg(t2)))

## test that all prototypes of nonvirtual classes are valid
for (cl in c(names(getClassDef("Matrix")@subclasses),
             names(getClassDef("MatrixFactorization")@subclasses)))
    if(!isVirtualClass(def <- getClassDef(cl))) validObject(new(def))

cat('Time elapsed: ', proc.time(),'\n') # "stats"

if(!interactive()) warnings()