SCM

SCM Repository

[matrix] Annotation of /pkg/Matrix/tests/validObj.R
ViewVC logotype

Annotation of /pkg/Matrix/tests/validObj.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3288 - (view) (download)

1 : maechler 509 library(Matrix)
2 : maechler 516 ### Do all kinds of object creation and coercion
3 : maechler 509
4 : maechler 907 source(system.file("test-tools.R", package = "Matrix"))
5 : maechler 516
6 : maechler 612 ## the empty ones:
7 : mmaechler 2175 checkMatrix(new("dgeMatrix"))
8 :     checkMatrix(Matrix(,0,0))
9 : maechler 538
10 : maechler 516 ## "dge"
11 : maechler 538 assertError( new("dgeMatrix", Dim = c(2,2), x= 1:4) )# double 'Dim'
12 :     assertError( new("dgeMatrix", Dim = as.integer(c(2,2)), x= 1:4) )# int 'x'
13 :     assertError( new("dgeMatrix", Dim = 2:2, x=as.double(1:4)) )# length(Dim) !=2
14 :     assertError( new("dgeMatrix", Dim = as.integer(c(2,2)), x= as.double(1:5)))
15 :    
16 : mmaechler 2175 checkMatrix(m1 <- Matrix(1:6, ncol=2))
17 :     checkMatrix(m2 <- Matrix(1:7 +0, ncol=3)) # a (desired) warning
18 : mmaechler 3192 c("dgeMatrix", "ddenseMatrix", "generalMatrix", "geMatrix", "dMatrix",
19 :     "denseMatrix", "compMatrix", "Matrix", "xMatrix", "mMatrix") -> m1.cl
20 :     stopifnot(!anyNA(match(m1.cl, is(m1))),
21 :     dim(t(m1)) == 2:3, identical(m1, t(t(m1))))
22 : maechler 579 c.nam <- paste("C",1:2, sep='')
23 :     dimnames(m1) <- list(NULL, c.nam)
24 : mmaechler 2225 checkMatrix(m1) # failed in 0.999375-10
25 :     checkMatrix(tm1 <- t(m1))
26 : maechler 579 stopifnot(colnames(m1) == c.nam,
27 : mmaechler 2225 identical(dimnames(tm1), list(c.nam, NULL)),
28 :     identical(m1, t(tm1)))
29 : maechler 538
30 : maechler 620 ## an example of *named* dimnames
31 :     (t34N <- as(unclass(table(x = gl(3,4), y=gl(4,3))), "dgeMatrix"))
32 :     stopifnot(identical(dimnames(t34N),
33 : maechler 1285 dimnames(as(t34N, "matrix"))),
34 :     identical(t34N, t(t(t34N))))
35 : maechler 579
36 : maechler 516 ## "dpo"
37 : mmaechler 2175 checkMatrix(cm <- crossprod(m1))
38 :     checkMatrix(cp <- as(cm, "dppMatrix"))# 'dpp' + factors
39 :     checkMatrix(cs <- as(cm, "dsyMatrix"))# 'dsy' + factors
40 :     checkMatrix(dcm <- as(cm, "dgeMatrix"))#'dge'
41 :     checkMatrix(mcm <- as(cm, "dMatrix")) # 'dsy' + factors -- buglet? rather == cm?
42 : mmaechler 2268 checkMatrix(mc. <- as(cm, "Matrix")) # dpo --> dsy -- (as above) FIXME? ??
43 : maechler 1285 stopifnot(identical(mc., mcm),
44 : mmaechler 2268 identical(cm, (2*cm)/2),# remains dpo
45 :     identical(cm + cp, cp + cs),# dge
46 :     identical(mc., mcm),
47 :     all(2*cm == mcm * 2))
48 : maechler 1665
49 : mmaechler 2175 checkMatrix(eq <- cm == cs)
50 : maechler 1665 stopifnot(all(eq@x),
51 : mmaechler 2807 identical3(pack(eq), cs == cp, cm == cp),
52 : maechler 1665 as.logical(!(cs < cp)),
53 :     identical4(!(cs < cp), !(cp > cs), cp <= cs, cs >= cp))
54 : maechler 516
55 : maechler 1189 ## Coercion to 'dpo' should give an error if result would be invalid
56 :     M <- Matrix(diag(4) - 1)
57 :     assertError(as(M, "dpoMatrix"))
58 :     M. <- as(M, "dgeMatrix")
59 :     M.[1,2] <- 10 # -> not even symmetric anymore
60 :     assertError(as(M., "dpoMatrix"))
61 :    
62 :    
63 : maechler 516 ## Cholesky
64 : mmaechler 2175 checkMatrix(ch <- chol(cm))
65 :     checkMatrix(ch2 <- chol(as(cm, "dsyMatrix")))
66 :     checkMatrix(ch3 <- chol(as(cm, "dgeMatrix")))
67 : maechler 2115 stopifnot(is.all.equal3(as(ch, "matrix"), as(ch2, "matrix"), as(ch3, "matrix")))
68 : maechler 850 ### Very basic triangular matrix stuff
69 : maechler 538
70 :     assertError( new("dtrMatrix", Dim = c(2,2), x= 1:4) )# double 'Dim'
71 :     assertError( new("dtrMatrix", Dim = as.integer(c(2,2)), x= 1:4) )# int 'x'
72 : maechler 577 ## This caused a segfault (before revision r1172 in ../src/dtrMatrix.c):
73 : maechler 538 assertError( new("dtrMatrix", Dim = 2:2, x=as.double(1:4)) )# length(Dim) !=2
74 :     assertError( new("dtrMatrix", Dim = as.integer(c(2,2)), x= as.double(1:5)))
75 :    
76 :     tr22 <- new("dtrMatrix", Dim = as.integer(c(2,2)), x=as.double(1:4))
77 : maechler 579 tt22 <- t(tr22)
78 :     (tPt <- tr22 + tt22)
79 :     stopifnot(identical(10 * tPt, tPt * 10),
80 : mmaechler 2268 as.vector(t.22 <- (tr22 / .5)* .5) == c(1,0,3,4),
81 : maechler 850 TRUE) ## not yet: class(t.22) == "dtrMatrix")
82 : maechler 538
83 : maechler 850 ## non-square triagonal Matrices --- are forbidden ---
84 : maechler 1165 assertError(new("dtrMatrix", Dim = 2:3,
85 : maechler 2106 x=as.double(1:6), uplo="L", diag="U"))
86 : maechler 1654
87 :     n <- 3:3
88 :     assertError(new("dtCMatrix", Dim = c(n,n), diag = "U"))
89 : mmaechler 3055 validObject(T <- new("dtTMatrix", Dim = c(n,n), diag = "U"))
90 :     validObject(M <- new("dtCMatrix", Dim = c(n,n), diag = "U",
91 :     p = rep.int(0:0, n+1)))
92 :     stopifnot(identical(as.mat(T), diag(n)))
93 : maechler 1673
94 : mmaechler 3288 suppressWarnings(RNGversion("3.5.0")); set.seed(3)
95 :     (p9 <- as(sample(9), "pMatrix"))
96 : mmaechler 3232 ## Check that the correct error message is triggered:
97 : maechler 1673 ind.try <- try(p9[1,1] <- 1, silent = TRUE)
98 : mmaechler 3232 np9 <- as(p9, "ngTMatrix")
99 :     stopifnot(grepl("replacing.*sensible", ind.try[1]),
100 : maechler 2106 is.logical(p9[1,]),
101 : mmaechler 2900 is(p9[2,, drop=FALSE], "indMatrix"),
102 :     is(p9[9:1,], "indMatrix"),
103 : maechler 2106 isTRUE(p9[-c(1:6, 8:9), 1]),
104 : maechler 1673 identical(t(p9), solve(p9)),
105 : mmaechler 3232 identical(p9[TRUE, ], p9),
106 :     all.equal(p9[, TRUE], np9), # currently...
107 : maechler 2106 identical(as(diag(9), "pMatrix"), as(1:9, "pMatrix"))
108 :     )
109 : mmaechler 3232 assert.EQ.mat(p9[TRUE,], as.matrix(np9))
110 : mmaechler 2235
111 : dmbates 2305 ## validObject --> Cparse_validate(.)
112 : mmaechler 2235 mm <- new("dgCMatrix", Dim = c(3L, 5L),
113 :     i = c(2L, 0L, 1L, 2L, 0L, 1L),
114 : dmbates 2305 x = c( 2, 1, 1, 2, 1, 2),
115 : mmaechler 2235 p = c(0:2, 4L, 4L, 6L))
116 : dmbates 2305
117 :     ## Previously unsorted columns were sorted - now are flagged as invalid
118 : mmaechler 2235 m. <- mm
119 :     ip <- c(1:2, 4:3, 6:5) # permute the 'i' and 'x' slot just "inside column":
120 :     m.@i <- m.i <- mm@i[ip]
121 :     m.@x <- m.x <- mm@x[ip]
122 : dmbates 2305 stopifnot(grep("row indices are not", validObject(m., test=TRUE)) == 1)
123 : mmaechler 2889 Matrix:::.sortCsparse(m.) # don't use this at home, boys!
124 :     m. # now is fixed
125 :    
126 : mmaechler 2236 ## Make sure that validObject() objects...
127 :     ## 1) to wrong 'p'
128 :     m. <- mm; m.@p[1] <- 1L
129 :     stopifnot(grep("first element of slot p", validObject(m., test=TRUE)) == 1)
130 :     m.@p <- mm@p[c(1,3:2,4:6)]
131 :     stopifnot(grep("^slot p.* non-decreasing", validObject(m., test=TRUE)) == 1)
132 :     ## 2) to non-strictly increasing i's:
133 :     m. <- mm ; ix <- c(1:3,3,5:6)
134 :     m.@i <- mm@i[ix]
135 :     m.@x <- mm@x[ix]
136 :     stopifnot(identical(grep("slot i is not.* increasing .*column$",
137 :     validObject(m., test=TRUE)), 1L))
138 : dmbates 2305 ## ix <- c(1:3, 3:6) # now the the (i,x) slots are too large (and decreasing at end)
139 :     ## m.@i <- mm@i[ix]
140 :     ## m.@x <- mm@x[ix]
141 :     ## stopifnot(identical(grep("^slot i is not.* increasing .*sort",
142 :     ## (msg <- validObject(m., test=TRUE))),# seg.fault in the past
143 :     ## 1L))
144 : mmaechler 2236
145 :     ## over-allocation of the i- and x- slot should be allowed:
146 :     ## (though it does not really help in M[.,.] <- * yet)
147 :     m. <- mm
148 :     m.@i <- c(mm@i, NA, NA, NA)
149 :     m.@x <- c(mm@x, 10:12)
150 : mmaechler 3055 validObject(m.)
151 : mmaechler 2236 m. # show() now works
152 :     stopifnot(all(m. == mm), # in spite of
153 :     length(m.@i) > length(mm@i),
154 :     identical(t(t(m.)), mm),
155 :     identical3(m. * m., m. * mm, mm * mm))
156 :     m.[1,4] <- 99 ## FIXME: warning and cuts (!) the over-allocated slots
157 : mmaechler 2279
158 :     ## Low-level construction of invalid object:
159 :     ## Ensure that it does *NOT* segfault
160 :     foo <- new("ngCMatrix",
161 :     i = as.integer(c(12204, 16799, 16799, 33517, 1128, 11930, 1128, 11930, 32183)),
162 :     p = rep(0:9, c(2,4,1,11,10,0,1,0,9,12)),
163 :     Dim = c(36952L, 49L))
164 :     validObject(foo)# TRUE
165 :     foo@i[5] <- foo@i[5] + 50000L
166 :     msg <- validObject(foo, test=TRUE)# is -- correctly -- *not* valid anymore
167 :     stopifnot(is.character(msg))
168 :     ## Error in validObject(foo) :
169 :     ## invalid class "ngCMatrix" object: all row indices must be between 0 and nrow-1
170 :     getLastMsg <- function(tryRes) {
171 :     ## Extract "final" message from erronous try result
172 :     sub("\n$", "",
173 :     sub(".*: ", "", as.character(tryRes)))
174 :     }
175 :     t <- try(show(foo)) ## error
176 :     t2 <- try(head(foo))
177 :     stopifnot(identical(msg, getLastMsg(t)),
178 :     identical(1L, grep("as_cholmod_sparse", getLastMsg(t2))))
179 :    
180 :    
181 : dmbates 2283 cat('Time elapsed: ', proc.time(),'\n') # "stats"
182 : mmaechler 2279
183 :     if(!interactive()) warnings()

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge