SCM

SCM Repository

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

Annotation of /pkg/Matrix/R/Summary.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3192 - (view) (download)

1 : mmaechler 3000 ####--- All "Summary" group methods for all Matrix classes (incl sparseVector) ------
2 :     #### ======= but diagonalMatrix -> ./diagMatrix.R and abIndex.R
3 :     #### ~~~~~~~~~~~~ ~~~~~~~~~
4 :    
5 :     ## M-x grep -E -e 'Method\("(Summary|max|min|range|all|any|prod|sum)"' *.R
6 :     ## ----
7 :    
8 :     sG <- getGroupMembers("Summary")
9 :     if(FALSE)
10 :     sG ## "max" "min" "range" "prod" "sum" "any" "all"
11 :     ## w/o "prod" & "sum":
12 :     summGener1 <- sG[match(sG, c("prod","sum"), 0) == 0]
13 :     rm(sG)
14 :    
15 :     ###---------- dMatrix
16 :    
17 :     setMethod("Summary", "ddenseMatrix",
18 :     function(x, ..., na.rm) {
19 :     d <- x@Dim
20 :     if(any(d == 0)) return(callGeneric(numeric(0), ..., na.rm=na.rm))
21 :     clx <- getClassDef(class(x))
22 :     if(extends(clx, "generalMatrix"))
23 :     callGeneric(x@x, ..., na.rm = na.rm)
24 :     else if(extends(clx, "symmetricMatrix")) { # incl packed, pos.def.
25 :     if(.Generic %in% summGener1) {
26 :     callGeneric(if (length(x@x) < prod(d)) x@x
27 :     else x@x[indTri(d[1], upper= x@uplo == "U",
28 :     diag= TRUE)],
29 :     ..., na.rm = na.rm)
30 : mmaechler 3079 } else callGeneric(..2dge(x)@x, ..., na.rm = na.rm)
31 : mmaechler 3000 }
32 :     else { ## triangular , possibly packed
33 :     if(.Generic %in% summGener1) {
34 : mmaechler 3069 if(.Generic %in% c("any","all")) {
35 : mmaechler 3100 Zero <- FALSE; One <- TRUE; xx <- as.logical(x@x)
36 : mmaechler 3069 } else {
37 : mmaechler 3100 Zero <- 0; One <- 1; xx <- x@x
38 : mmaechler 3069 }
39 : mmaechler 3100 callGeneric(if (length(xx) < prod(d)) xx ## <- 'packed'
40 :     else xx[indTri(d[1], upper= x@uplo == "U",
41 : mmaechler 3069 diag= TRUE)],
42 :     if(d[1] >= 2) Zero, if(x@diag == "U") One,
43 : mmaechler 3000 ..., na.rm = na.rm)
44 : mmaechler 3079 } else callGeneric(..2dge(x)@x, ..., na.rm = na.rm)
45 : mmaechler 3000 }
46 :     })
47 :    
48 :     setMethod("Summary", "dsparseMatrix",
49 :     function(x, ..., na.rm)
50 :     {
51 :     ne <- prod(d <- dim(x))
52 :     if(ne == 0) return(callGeneric(numeric(0), ..., na.rm=na.rm))
53 :     n <- d[1]
54 :     clx <- getClassDef(class(x))
55 :     isTri <- extends(clx, "triangularMatrix")
56 : mmaechler 3059 if(extends(clx, "TsparseMatrix") && anyDuplicatedT(x, di = d))
57 : mmaechler 3000 x <- .Call(Tsparse_to_Csparse, x, isTri)# = as(x, "Csparsematrix")
58 :     l.x <- length(x@x)
59 :     if(l.x == ne) ## fully non-zero (and "general") - very rare but quick
60 :     return( callGeneric(x@x, ..., na.rm = na.rm) )
61 :     ## else l.x < ne
62 :    
63 :     isSym <- !isTri && extends(clx, "symmetricMatrix")
64 :     isU.tri <- isTri && x@diag == "U"
65 :     ## "full": has *no* structural zero : very rare, but need to catch :
66 :     full.x <- ((isSym && l.x == choose(n+1, 2)) ||
67 :     (n == 1 && (isU.tri || l.x == 1)))
68 :     isGener1 <- .Generic %in% summGener1
69 :     if(isGener1) { ## not prod() or sum() -> no need check for symmetric
70 :     ## we rely on <generic>(x, NULL, y, ..) :== <generic>(x, y, ..):
71 : mmaechler 3100 if(any(.Generic == c("any","all"))) ## logic:
72 :     callGeneric(as.logical(x@x), if(!full.x) FALSE, if(isU.tri) TRUE,
73 :     ..., na.rm = na.rm)
74 :     else
75 :     callGeneric(x@x, if(!full.x) 0, if(isU.tri) 1,
76 :     ..., na.rm = na.rm)
77 : mmaechler 3000 }
78 :     else { ## prod() or sum() : care for "symmetric" and U2N
79 :     if(!full.x && .Generic == "prod") {
80 : mmaechler 3092 if(anyNA(x@x)) NaN else 0
81 : mmaechler 3000 }
82 :     else
83 :     callGeneric((if(isSym) as(x, "generalMatrix") else x)@x,
84 :     if(!full.x) 0, # one 0 <==> many 0's
85 :     if(isU.tri) rep.int(1, n),
86 :     ..., na.rm = na.rm)
87 :     }
88 :     })
89 :    
90 :     ###---------- ldenseMatrix
91 :    
92 :     if(FALSE) # not correct (@x may contain "wrong" in "other" triangel
93 :     setMethod("all", "lsyMatrix",
94 :     function(x, ..., na.rm = FALSE)
95 :     all(x@x, ..., na.rm = na.rm))
96 :     if(FALSE) # replaced by "Summary" below
97 :     ## Note: the above "lsy*" method is needed [case below can be wrong]
98 :     setMethod("all", "ldenseMatrix",
99 :     function(x, ..., na.rm = FALSE) {
100 :     if(prod(dim(x)) >= 1)
101 :     (!is(x, "triangularMatrix") && !is(x, "diagonalMatrix") &&
102 :     all(x@x, ..., na.rm = na.rm))
103 :     else all(x@x, ..., na.rm = na.rm)
104 :     })
105 :    
106 :     ## almost copy_paste from "ddenseMatrix" above
107 :     Summ.ln.dense <- function(x, ..., na.rm) {
108 :     d <- x@Dim
109 :     if(any(d == 0)) return(callGeneric(logical(0), ..., na.rm=na.rm))
110 :     ext <- extends(getClassDef(class(x)))
111 :     if(any("generalMatrix" == ext))
112 :     callGeneric(x@x, ..., na.rm = na.rm)
113 :     else if(any("symmetricMatrix" == ext)) { # incl packed, pos.def.
114 :     if(.Generic != "sum") { ## i.e., %in% summGener1
115 :     callGeneric(if (length(x@x) < prod(d)) x@x
116 :     else x@x[indTri(d[1], upper= x@uplo == "U",
117 :     diag= TRUE)],
118 :     ..., na.rm = na.rm)
119 :     } else ## sum() -- FIXME-faster: use x@x[indTri(...)] similar to above
120 :     callGeneric(as(x, paste0(if(any("ldenseMatrix" == ext)) "l" else "n", "geMatrix"))@x,
121 :     ..., na.rm = na.rm)
122 :     }
123 :     else { ## triangular , possibly packed
124 :     if(.Generic != "sum") ## incl. prod() !
125 :     callGeneric(x@x, if(d[1] >= 2) FALSE, if(x@diag == "U") TRUE, ..., na.rm = na.rm)
126 :     else ## sum() -- FIXME-faster: using indTri()..; in unit-diag. case: plus n x TRUE = d[1]
127 :     ## if packed: sum(x@x, if(x@diag == "U") d[1], ..., na.rm = na.rm)
128 :     callGeneric(as(x, paste0(if(any("ldenseMatrix" == ext)) "l" else "n", "geMatrix"))@x,
129 :     ..., na.rm = na.rm)
130 :     }
131 :     }
132 :    
133 :     setMethod("Summary", "ldenseMatrix", Summ.ln.dense)
134 :     setMethod("Summary", "ndenseMatrix", Summ.ln.dense)
135 :    
136 :    
137 :     ###---------- lMatrix
138 :    
139 :     setMethod("any", "lMatrix",
140 :     function(x, ..., na.rm = FALSE)
141 :     ## logical unit-triangular has TRUE diagonal:
142 :     (prod(dim(x)) >= 1 && is(x, "triangularMatrix") && x@diag == "U") ||
143 :     any(x@x, ..., na.rm = na.rm))
144 :    
145 :     ###---------- lsparseMatrix
146 :    
147 :     ##------- Work via as(*, lgC) : ------------
148 :    
149 :     setMethod("all", "lsparseMatrix",
150 :     function(x, ..., na.rm = FALSE) {
151 :     d <- x@Dim
152 :     l.x <- length(x@x)
153 :     if(l.x == prod(d)) ## fully non-zero
154 :     all(x@x, ..., na.rm = na.rm)
155 :     else if(is(x, "symmetricMatrix") && l.x == choose(d[1]+1, 2)) {
156 :     if(.Generic %in% summGener1)
157 :     all(x@x, ..., na.rm = na.rm)
158 :     else all(as(x, "generalMatrix")@x, ..., na.rm = na.rm)
159 :     }
160 :     else FALSE ## has at least one structural 0
161 :     })
162 :    
163 :    
164 :     ###---------- Matrix
165 :    
166 :     ## For all other Matrix objects {and note that "all" and "any" have their own}:
167 :    
168 :     setMethod("all", "Matrix",
169 :     function(x, ..., na.rm)
170 :     callGeneric(as(x, "lMatrix"), ..., na.rm=na.rm))
171 :    
172 :     setMethod("any", "Matrix",
173 :     function(x, ..., na.rm)
174 :     callGeneric(as(x, "lMatrix"), ..., na.rm=na.rm))
175 :    
176 :     setMethod("Summary", "Matrix", ## FIXME (too cheap): all(<lMatrix>) should not go via dMatrix!!
177 :     function(x, ..., na.rm)
178 :     callGeneric(as(x,"dMatrix"), ..., na.rm = na.rm))
179 :    
180 :     ## Try to make min(1, <Matrix>) work, i.e., not dispatch on first arg to .Primitive
181 :     ## This for(..) gives {during installation}
182 :     ## Error in setGeneric(F, signature = "...") :
183 :     ## ‘max’ is a primitive function; methods can be defined, but the generic function is implicit, and cannot be changed.
184 :     if(FALSE)
185 :     for(F in c("max", "min", "range", "prod", "sum", "any", "all")) {
186 :     setGeneric(F, signature = "...")
187 :     }
188 :     ## try on "min" for now --- ~/R/Pkgs/Rmpfr/R/mpfr.R is the example (for "pmin")
189 :     if(FALSE)## This gives error message that the "ANY" is method is sealed ...
190 :     setMethod("min", "ANY",
191 :     function(..., na.rm = FALSE) {
192 :     args <- list(...)
193 :     if(all(isAtm <- vapply(args, is.atomic, NA)))
194 :     return( base::min(..., na.rm = na.rm) )
195 :     ## else try to dispatch on an argument which is a Matrix.. or in a
196 :     if(any(isM <- vapply(args, is, NA, class2="Matrix"))) {
197 :     ## swap the Matrix with the first argument
198 :     i <- which.max(isM)# the first "Matrix"
199 :     if(i == 1)
200 :     stop("programming error: min() should have dispatched w/ 1st arg much earlier")
201 :     } else { ## if no "Matrix", take the first non-atomic argument
202 :     ## (FIXME: should take the first for which there is a method !)
203 :     i <- which.max(!isAtm)
204 :     }
205 :     ii <- seq_along(args)
206 :     ii[c(1,i)] <- c(i,1)
207 :     do.call(min, c(args[ii], list(na.rm=na.rm)))
208 :     })
209 :    
210 :     if(FALSE) { ## FIXME: it does *not* solve the problem anyway ..
211 :     ##
212 :     ## (m <- Matrix(c(0,0,2:0), 3,5))
213 :     ## min(1,m)
214 :     ##-> error, as it calls the .Primitive min() and that does *not* dispatch on 2nd arg
215 :     ##
216 :     setMethod("Summary", "ANY",
217 :     function(x, ..., na.rm) {
218 :     if(!length(a <- list(...))) (get(.Generic, envir=baseenv()))(x, na.rm=na.rm)
219 :     else {
220 :     if(!is.null(v <- getOption("Matrix.verbose")) && v >= 1)
221 :     if(length(a) > 1)
222 :     message(gettextf("in Summary(<ANY>, .): %s(<%s>, <%s>,...)\n",
223 :     .Generic, class(x), class(a[[1]])), domain = NA)
224 :     else
225 :     message(gettextf("in Summary(<ANY>, .): %s(<%s>, <%s>)\n",
226 :     .Generic, class(x), class(a[[1]])), domain = NA)
227 :    
228 :     do.call(.Generic, c(x, a, list(na.rm=na.rm)))
229 :     }})
230 :     }## {does not help --> not used}
231 :    
232 :     Summary.l <- function(x, ..., na.rm) { ## must be method directly
233 :     if(.Generic %in% c("all", "any"))
234 :     callGeneric(x@x, ..., na.rm = na.rm)
235 :     else {
236 :     r <- callGeneric(as(x,"dMatrix"), ..., na.rm = na.rm)
237 :     if(.Generic != "prod" && !any(is.infinite(r))) as.integer(r) else r
238 :     }
239 :     }
240 :     ## almost identical:
241 :     Summary.np <- function(x, ..., na.rm) {
242 :     if(.Generic %in% c("all", "any"))
243 :     callGeneric(as(x, "lMatrix"), ..., na.rm = na.rm)
244 :     else {
245 :     r <- callGeneric(as(x,"dMatrix"), ..., na.rm = na.rm)
246 :     if(.Generic != "prod" && !any(is.infinite(r))) as.integer(r) else r
247 :     }
248 :     }
249 :     ##
250 :     setMethod("Summary", "lMatrix", Summary.l)
251 :     setMethod("Summary", "nMatrix", Summary.np)
252 :     setMethod("Summary", "indMatrix", Summary.np)
253 :    
254 :     ###---------- nsparseMatrix
255 :    
256 :     setMethod("all", "nsparseMatrix",
257 :     function(x, ..., na.rm = FALSE) {
258 :     pd <- prod(d <- dim(x))
259 :     if(pd == 0) return(TRUE)
260 :     cld <- getClassDef(class(x))
261 :     if(extends(cld, "triangularMatrix"))
262 :     return(FALSE)
263 :     ## else
264 :     if(extends(cld, "TsparseMatrix"))
265 :     cld <- getClassDef(class(x <- as(x, "CsparseMatrix")))
266 :     ## now have Csparse or Rsparse: length of index slot = no.{TRUE}
267 :     l.x <- length(if(extends(cld, "CsparseMatrix")) x@i else x@j)
268 :    
269 :     (l.x == pd) || ## fully non-zero
270 :     (extends(cld, "symmetricMatrix") && l.x == choose(d[1]+1, 2))
271 :     ## else FALSE
272 :     })
273 :    
274 :     setMethod("any", "nsparseMatrix",
275 :     function(x, ..., na.rm = FALSE) {
276 :     if(any(dim(x) == 0)) return(FALSE)
277 :     cld <- getClassDef(class(x))
278 :     if(extends(cld, "triangularMatrix") && x@diag == "U")
279 :     TRUE # unit-diagonal
280 :     else if(extends(cld, "CsparseMatrix") ||
281 :     extends(cld, "TsparseMatrix"))
282 :     length(x@i) > 0
283 :     else # RsparseMatrix
284 :     length(x@j) > 0
285 :     })
286 :    
287 :    
288 :     ###---------- sparseVector
289 :    
290 :     setMethod("Summary", "nsparseVector",
291 :     function(x, ..., na.rm) { ## no 'x' slot, no NA's ..
292 :     n <- x@length
293 :     l.x <- length(x@i)
294 :     if(l.x == n)
295 :     callGeneric(rep.int(TRUE, n), ..., na.rm = na.rm)
296 :     else ## l.x < n : has some FALSE entries
297 :     switch(.Generic,
298 :     "prod" = 0,
299 :     "min" = 0L,
300 :     "all" = FALSE,
301 :     "any" = l.x > 0,
302 :     "sum" = l.x,
303 :     "max" = as.integer(l.x > 0),
304 :     "range" = c(0L, as.integer(l.x > 0)))
305 :     })
306 :    
307 :     ## The "other" "sparseVector"s ("d", "l", "i" ..): all have an 'x' slot :
308 :     setMethod("Summary", "sparseVector",
309 :     function(x, ..., na.rm) {
310 :     n <- x@length
311 :     l.x <- length(x@x)
312 :     if(l.x == n) ## fully non-zero (and "general") - very rare but quick
313 :     callGeneric(x@x, ..., na.rm = na.rm)
314 :     else if(.Generic != "prod") {
315 :     ## we rely on <generic>(x, NULL, y, ..) :== <generic>(x, y, ..):
316 : mmaechler 3099 if(any(.Generic == c("any","all"))) ## logic:
317 :     callGeneric(as.logical(x@x), FALSE, ..., na.rm = na.rm)
318 :     else # "numeric"
319 :     callGeneric(x@x, 0, ..., na.rm = na.rm)
320 : mmaechler 3000 }
321 :     else { ## prod()
322 : mmaechler 3092 if(anyNA(x@x)) NaN else 0
323 : mmaechler 3000 }
324 :     })
325 : mmaechler 3192
326 :     ## help( pmin ) in R :
327 :     ## -----
328 :     ## ‘pmax’ and ‘pmin’ will also work on classed objects with appropriate methods
329 :     ## for comparison, ‘is.na’ and ‘rep’ (if recycling of arguments is needed).
330 :     ##
331 :     ##--> and that now *does* work, in 'R 3.3.1 patched' and newer

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