SCM

SCM Repository

[matrix] Annotation of /pkg/R/sparseMatrix.R
ViewVC logotype

Annotation of /pkg/R/sparseMatrix.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1479 - (view) (download)

1 : bates 684 ### Define Methods that can be inherited for all subclasses
2 :    
3 : maechler 925 ### Idea: Coercion between *VIRTUAL* classes -- as() chooses "closest" classes
4 :     ### ---- should also work e.g. for dense-triangular --> sparse-triangular !
5 : maechler 868
6 : maechler 1472 ##-> see als ./dMatrix.R, ./ddenseMatrix.R and ./lMatrix.R
7 : maechler 868
8 : maechler 1472 setAs("ANY", "sparseMatrix", function(from) as(from, "CsparseMatrix"))
9 : maechler 868
10 : maechler 1472
11 : maechler 871 ## "graph" coercions -- this needs the graph package which is currently
12 :     ## ----- *not* required on purpose
13 :     ## Note: 'undirected' graph <==> 'symmetric' matrix
14 :    
15 : maechler 1271 ## Add some utils that may no longer be needed in future versions of the 'graph' package
16 :     graph.has.weights <- function(g) "weight" %in% names(edgeDataDefaults(g))
17 :    
18 :     graph.wgtMatrix <- function(g)
19 :     {
20 :     ## Purpose: work around "graph" package's as(g, "matrix") bug
21 :     ## ----------------------------------------------------------------------
22 :     ## Arguments: g: an object inheriting from (S4) class "graph"
23 :     ## ----------------------------------------------------------------------
24 :     ## Author: Martin Maechler, based on Seth Falcon's code; Date: 12 May 2006
25 :    
26 :     ## MM: another buglet for the case of "no edges":
27 :     if(numEdges(g) == 0) {
28 :     p <- length(nd <- nodes(g))
29 :     return( matrix(0, p,p, dimnames = list(nd, nd)) )
30 :     }
31 :     ## Usual case, when there are edges:
32 :     has.w <- "weight" %in% names(edgeDataDefaults(g))
33 :     if(has.w) {
34 :     w <- unlist(edgeData(g, attr = "weight"))
35 :     has.w <- any(w != 1)
36 :     } ## now 'has.w' is TRUE iff there are weights != 1
37 :     m <- as(g, "matrix")
38 :     ## now is a 0/1 - matrix (instead of 0/wgts) with the 'graph' bug
39 :     if(has.w) { ## fix it if needed
40 :     tm <- t(m)
41 :     tm[tm != 0] <- w
42 :     t(tm)
43 :     }
44 :     else m
45 :     }
46 :    
47 :    
48 :     setAs("graphAM", "sparseMatrix",
49 : bates 862 function(from) {
50 : maechler 1271 symm <- edgemode(from) == "undirected" && isSymmetric(from@adjMat)
51 :     ## This is only ok if there are no weights...
52 :     if(graph.has.weights(from)) {
53 :     as(graph.wgtMatrix(from),
54 :     if(symm) "dsTMatrix" else "dgTMatrix")
55 :     }
56 :     else { ## no weights: 0/1 matrix -> logical
57 :     as(as(from, "matrix"),
58 :     if(symm) "lsTMatrix" else "lgTMatrix")
59 :     }
60 : bates 862 })
61 : maechler 1271
62 : bates 1476 setAs("graph", "CsparseMatrix",
63 : bates 1479 function(from) as(as(from, "graphNEL"), "CsparseMatrix"))
64 : maechler 687
65 : bates 1474 setAs("graphNEL", "CsparseMatrix",
66 : maechler 1271 function(from) {
67 :     nd <- nodes(from)
68 : bates 1474 dm <- rep.int(length(nd), 2)
69 : maechler 1271 symm <- edgemode(from) == "undirected"
70 : bates 1474
71 :     ## if(graph.has.weights(from)) {
72 :     ## .bail.out.2(.Generic, class(from), to)
73 :     ## ## symm <- symm && <weights must also be symmetric>: improbable
74 :     ## ## if(symm) new("dsTMatrix", .....) else
75 :     ## ##new("dgTMatrix", )
76 :     ## }
77 :     ## else { ## no weights: 0/1 matrix -> logical
78 :     edges <- lapply(from@edgeL[nd], "[[", "edges")
79 :     lens <- unlist(lapply(edges, length))
80 :     nnz <- sum(unlist(lens)) # number of non-zeros
81 :     i <- unname(unlist(edges) - 1:1) # row indices (0-based)
82 :     j <- rep.int(0:(dm[1]-1), lens) # column indices (0-based)
83 :     if(symm) { # ensure upper triangle
84 :     tmp <- i
85 :     flip <- i > j
86 :     i[flip] <- j[flip]
87 :     j[flip] <- tmp[flip]
88 :     dtm <- new("lsTMatrix", i = i, j = j, Dim = dm,
89 :     Dimnames = list(nd, nd), uplo = "U")
90 :     } else {
91 :     dtm <- new("lgTMatrix", i = i, j = j, Dim = dm,
92 :     Dimnames = list(nd, nd))
93 :     }
94 :     as(dtm, "CsparseMatrix")
95 :     ## }
96 : maechler 1271 })
97 : maechler 687
98 : maechler 871 setAs("sparseMatrix", "graph", function(from) as(from, "graphNEL"))
99 :     setAs("sparseMatrix", "graphNEL",
100 : maechler 1271 function(from) as(as(from, "TsparseMatrix"), "graphNEL"))
101 : maechler 908
102 : maechler 1348 Tsp2grNEL <- function(from) {
103 :     d <- dim(from)
104 :     if(d[1] != d[2])
105 :     stop("only square matrices can be used as incidence matrices for grphs")
106 :     n <- d[1]
107 :     if(n == 0) return(new("graphNEL"))
108 :     if(is.null(rn <- dimnames(from)[[1]]))
109 :     rn <- as.character(1:n)
110 :     from <- uniq(from) ## Need to 'uniquify' the triplets!
111 : maechler 908
112 : maechler 1348 if(isSymmetric(from)) { # either "symmetricMatrix" or otherwise
113 :     ##-> undirected graph: every edge only once!
114 :     if(!is(from, "symmetricMatrix")) {
115 :     ## a general matrix which happens to be symmetric
116 :     ## ==> remove the double indices
117 :     from <- tril(from)
118 :     }
119 :     ## every edge is there only once, either upper or lower triangle
120 :     ft1 <- cbind(from@i + 1:1, from@j + 1:1)
121 :     graph::ftM2graphNEL(ft1, W = from@x, V= rn, edgemode= "undirected")
122 : maechler 871
123 : maechler 1348 } else { ## not symmetric
124 : maechler 871
125 : maechler 1348 graph::ftM2graphNEL(cbind(from@i + 1:1, from@j + 1:1),
126 :     W = from@x, V= rn, edgemode= "directed")
127 :     }
128 : maechler 871
129 : maechler 1348 }
130 :     setAs("TsparseMatrix", "graphNEL", Tsp2grNEL)
131 : maechler 871
132 : maechler 1348
133 : maechler 868 ### Subsetting -- basic things (drop = "missing") are done in ./Matrix.R
134 : maechler 687
135 : maechler 925 ### FIXME : we defer to the "*gT" -- conveniently, but not efficient for gC !
136 : maechler 687
137 : maechler 925 ## [dl]sparse -> [dl]gT -- treat both in one via superclass
138 :     ## -- more useful when have "z" (complex) and even more
139 : maechler 687
140 : maechler 925 setMethod("[", signature(x = "sparseMatrix", i = "index", j = "missing",
141 : maechler 868 drop = "logical"),
142 : maechler 925 function (x, i, j, drop) {
143 :     cl <- class(x)
144 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
145 :     x <- callGeneric(x = as(x, viaCl), i=i, drop=drop)
146 : maechler 973 ## try_as(x, c(cl, sub("T","C", viaCl)))
147 :     if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
148 :     as(x, sub("T","C", viaCl)) else x
149 : maechler 925 })
150 : maechler 687
151 : maechler 925 setMethod("[", signature(x = "sparseMatrix", i = "missing", j = "index",
152 : maechler 868 drop = "logical"),
153 : maechler 925 function (x, i, j, drop) {
154 :     cl <- class(x)
155 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
156 :     x <- callGeneric(x = as(x, viaCl), j=j, drop=drop)
157 : maechler 973 ## try_as(x, c(cl, sub("T","C", viaCl)))
158 :     if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
159 :     as(x, sub("T","C", viaCl)) else x
160 : maechler 925 })
161 : maechler 868
162 : maechler 925 setMethod("[", signature(x = "sparseMatrix",
163 : maechler 886 i = "index", j = "index", drop = "logical"),
164 : maechler 925 function (x, i, j, drop) {
165 :     cl <- class(x)
166 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
167 :     x <- callGeneric(x = as(x, viaCl), i=i, j=j, drop=drop)
168 : maechler 973 ## try_as(x, c(cl, sub("T","C", viaCl)))
169 :     if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
170 :     as(x, sub("T","C", viaCl)) else x
171 : maechler 925 })
172 : maechler 868
173 :    
174 : maechler 1226 ## setReplaceMethod("[", signature(x = "sparseMatrix", i = "index", j = "missing",
175 :     ## value = "numeric"),
176 :     ## function (x, i, value) {
177 :    
178 :     ## stop("NOT YET")
179 :    
180 :     ## as(r, class(x))
181 :     ## })
182 :    
183 :     ## setReplaceMethod("[", signature(x = "sparseMatrix", i = "missing", j = "index",
184 :     ## value = "numeric"),
185 :     ## function (x, j, value) {
186 :    
187 :     ## stop("NOT YET")
188 :    
189 :     ## as(r, class(x))
190 :     ## })
191 :    
192 :     ## setReplaceMethod("[", signature(x = "sparseMatrix", i = "index", j = "index",
193 :     ## value = "numeric"),
194 :    
195 :     ## stop("NOT YET")
196 :    
197 :     ## as(r, class(x))
198 :     ## })
199 :    
200 :    
201 :    
202 : maechler 956 setMethod("-", signature(e1 = "sparseMatrix", e2 = "missing"),
203 :     function(e1) { e1@x <- -e1@x ; e1 })
204 :     ## with the following exceptions:
205 :     setMethod("-", signature(e1 = "lsparseMatrix", e2 = "missing"),
206 :     function(e1) callGeneric(as(e1, "dgCMatrix")))
207 :     setMethod("-", signature(e1 = "pMatrix", e2 = "missing"),
208 :     function(e1) callGeneric(as(e1, "lgTMatrix")))
209 : maechler 868
210 : maechler 1472 ## Group method "Arith"
211 :    
212 :     ## have CsparseMatrix methods (-> ./Csparse.R )
213 :     ## which may preserve "symmetric", "triangular" -- simply defer to those:
214 :    
215 :     setMethod("Arith", ## "+", "-", "*", "^", "%%", "%/%", "/"
216 :     signature(e1 = "sparseMatrix", e2 = "sparseMatrix"),
217 :     function(e1, e2) callGeneric(as(e1, "CsparseMatrix"),
218 :     as(e2, "CsparseMatrix")))
219 :     setMethod("Arith",
220 :     signature(e1 = "sparseMatrix", e2 = "numeric"),
221 :     function(e1, e2) callGeneric(as(e1, "CsparseMatrix"), e2))
222 :     setMethod("Arith",
223 :     signature(e1 = "numeric", e2 = "sparseMatrix"),
224 :     function(e1, e2) callGeneric(e1, as(e2, "CsparseMatrix")))
225 :    
226 :     setMethod("Math",
227 :     signature(x = "sparseMatrix"),
228 :     function(x) callGeneric(as(x, "CsparseMatrix")))
229 :    
230 :    
231 :    
232 : maechler 687 ### --- show() method ---
233 :    
234 : maechler 1389 ## FIXME(?) -- ``merge this'' (at least ``synchronize'') with
235 :     ## - - - prMatrix() from ./Auxiliaries.R
236 :     prSpMatrix <- function(object, digits = getOption("digits"),
237 :     maxp = getOption("max.print"), zero.print = ".")
238 : maechler 687 {
239 :     stopifnot(is(object, "sparseMatrix"))
240 : maechler 1390 d <- dim(object)
241 : maechler 1389 if(prod(d) > maxp) { # "Large" => will be "cut"
242 :     ## only coerce to dense that part which won't be cut :
243 :     nr <- maxp %/% d[2]
244 :     m <- as(object[1:max(1, nr), ,drop=FALSE], "Matrix")
245 :     } else {
246 :     m <- as(object, "matrix")
247 :     }
248 : maechler 1315 logi <- is(object,"lsparseMatrix")
249 :     if(logi)
250 :     x <- array(character(length(m)), dim(m), dimnames=dimnames(m))
251 :     else {
252 :     x <- apply(m, 2, format)
253 :     if(is.null(dim(x))) {# e.g. in 1 x 1 case
254 :     dim(x) <- dim(m)
255 :     dimnames(x) <- dimnames(m)
256 :     }
257 : maechler 687 }
258 :     x <- emptyColnames(x)
259 :     if(is.logical(zero.print))
260 :     zero.print <- if(zero.print) "0" else " "
261 : maechler 1315 if(logi) {
262 :     x[!m] <- zero.print
263 :     x[m] <- "|"
264 :     } else { # non logical
265 :     ## show only "structural" zeros as 'zero.print', not all of them..
266 :     ## -> cannot use 'm'
267 :     iN0 <- 1:1 + encodeInd(non0ind(object), nr = nrow(x))
268 : maechler 1467 if(length(iN0)) x[-iN0] <- zero.print else x[] <- zero.print
269 : maechler 1315 }
270 : maechler 687 print(noquote(x))
271 :     invisible(object)
272 :     }
273 :    
274 :     setMethod("show", signature(object = "sparseMatrix"),
275 :     function(object) {
276 :     d <- dim(object)
277 :     cl <- class(object)
278 :     cat(sprintf('%d x %d sparse Matrix of class "%s"\n', d[1], d[2], cl))
279 :     maxp <- getOption("max.print")
280 :     if(prod(d) <= maxp)
281 : maechler 1389 prSpMatrix(object, maxp = maxp)
282 : maechler 687 else { ## d[1] > maxp / d[2] >= nr : -- this needs [,] working:
283 :     nr <- maxp %/% d[2]
284 :     n2 <- ceiling(nr / 2)
285 :     nR <- d[1] # nrow
286 :     prSpMatrix(object[seq(length = min(nR, max(1, n2))), drop = FALSE])
287 :     cat("\n ..........\n\n")
288 :     prSpMatrix(object[seq(to = nR, length = min(max(1, nr-n2), nR)),
289 :     drop = FALSE])
290 :     invisible(object)
291 :     }
292 :     })
293 : maechler 886
294 :    
295 :     ## not exported:
296 : maechler 1108 setMethod("isSymmetric", signature(object = "sparseMatrix"),
297 : maechler 973 function(object, tol = 100*.Machine$double.eps) {
298 : maechler 886 ## pretest: is it square?
299 :     d <- dim(object)
300 :     if(d[1] != d[2]) return(FALSE)
301 :     ## else slower test
302 : maechler 973 if (is(object, "dMatrix"))
303 : maechler 886 ## use gC; "T" (triplet) is *not* unique!
304 :     isTRUE(all.equal(as(object, "dgCMatrix"),
305 : maechler 973 as(t(object), "dgCMatrix"), tol = tol))
306 :     else if (is(object, "lMatrix"))
307 : maechler 886 ## test for exact equality; FIXME(?): identical() too strict?
308 :     identical(as(object, "lgCMatrix"),
309 :     as(t(object), "lgCMatrix"))
310 :     else stop("not yet implemented")
311 :     })
312 : maechler 1174
313 : maechler 1238
314 : maechler 1174 setMethod("isTriangular", signature(object = "sparseMatrix"),
315 : maechler 1238 function(object, upper = NA)
316 :     isTriC(as(object, "CsparseMatrix"), upper))
317 : maechler 1174
318 :     setMethod("isDiagonal", signature(object = "sparseMatrix"),
319 :     function(object) {
320 :     gT <- as(object, "TsparseMatrix")
321 :     all(gT@i == gT@j)
322 :     })
323 :    
324 : maechler 1290
325 : maechler 1472 setMethod("diag", signature(x = "sparseMatrix"),
326 :     function(x, nrow, ncol = n) diag(as(x, "CsparseMatrix")))
327 :    
328 : maechler 1315 ## .as.dgT.Fun
329 : maechler 1290 setMethod("colSums", signature(x = "sparseMatrix"), .as.dgT.Fun)
330 :     setMethod("colMeans", signature(x = "sparseMatrix"), .as.dgT.Fun)
331 : maechler 1315 ## .as.dgC.Fun
332 : maechler 1290 setMethod("rowSums", signature(x = "sparseMatrix"), .as.dgC.Fun)
333 :     setMethod("rowMeans", signature(x = "sparseMatrix"),.as.dgC.Fun)

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