SCM

SCM Repository

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

Annotation of /pkg/R/Auxiliaries.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1472 - (view) (download)

1 : maechler 632 #### "Namespace private" Auxiliaries such as method functions
2 :     #### (called from more than one place --> need to be defined early)
3 :    
4 : maechler 1472 .isR_24 <- (paste(R.version$major, R.version$minor, sep=".") >= "2.4")
5 :    
6 : maechler 1467 ## Need to consider NAs ; "== 0" even works for logical & complex:
7 :     is0 <- function(x) !is.na(x) & x == 0
8 :     all0 <- function(x) !any(is.na(x)) && all(x == 0)
9 :    
10 : maechler 656 ## For %*% (M = Matrix; v = vector (double or integer {complex maybe?}):
11 :     .M.v <- function(x, y) callGeneric(x, as.matrix(y))
12 :     .v.M <- function(x, y) callGeneric(rbind(x), y)
13 : maechler 632
14 : maechler 1332 .M.DN <- function(x) if(!is.null(dn <- dimnames(x))) dn else list(NULL,NULL)
15 :    
16 : maechler 656 .has.DN <- ## has non-trivial Dimnames slot?
17 :     function(x) !identical(list(NULL,NULL), x@Dimnames)
18 :    
19 : maechler 949 .bail.out.1 <- function(fun, cl) {
20 :     stop(gettextf('not-yet-implemented method for %s(<%s>)', fun, cl),
21 : maechler 1238 call. = FALSE)
22 : maechler 949 }
23 :     .bail.out.2 <- function(fun, cl1, cl2) {
24 :     stop(gettextf('not-yet-implemented method for %s(<%s>, <%s>)',
25 : maechler 1238 fun, cl1, cl2), call. = FALSE)
26 : maechler 949 }
27 :    
28 : maechler 632 ## chol() via "dpoMatrix"
29 :     cholMat <- function(x, pivot, LINPACK) {
30 :     px <- as(x, "dpoMatrix")
31 : bates 703 if (isTRUE(validObject(px, test=TRUE))) chol(px)
32 : maechler 632 else stop("'x' is not positive definite -- chol() undefined.")
33 :     }
34 : maechler 908
35 : maechler 954 dimCheck <- function(a, b) {
36 :     da <- dim(a)
37 :     db <- dim(b)
38 :     if(any(da != db))
39 :     stop(gettextf("Matrices must have same dimensions in %s",
40 :     deparse(sys.call(sys.parent()))),
41 :     call. = FALSE)
42 :     da
43 :     }
44 :    
45 : maechler 956 dimNamesCheck <- function(a, b) {
46 :     ## assume dimCheck() has happened before
47 :     nullDN <- list(NULL,NULL)
48 :     h.a <- !identical(nullDN, dna <- dimnames(a))
49 :     h.b <- !identical(nullDN, dnb <- dimnames(b))
50 :     if(h.a || h.b) {
51 : maechler 1084 if (!h.b) dna
52 :     else if(!h.a) dnb
53 : maechler 956 else { ## both have non-trivial dimnames
54 :     r <- dna # "default" result
55 :     for(j in 1:2) {
56 :     dn <- dnb[[j]]
57 :     if(is.null(r[[j]]))
58 :     r[[j]] <- dn
59 :     else if (!is.null(dn) && any(r[[j]] != dn))
60 :     warning(gettextf("dimnames [%d] mismatch in %s", j,
61 :     deparse(sys.call(sys.parent()))),
62 :     call. = FALSE)
63 :     }
64 :     r
65 :     }
66 :     }
67 :     else
68 :     nullDN
69 :     }
70 :    
71 : maechler 908 rowCheck <- function(a, b) {
72 :     da <- dim(a)
73 :     db <- dim(b)
74 :     if(da[1] != db[1])
75 :     stop(gettextf("Matrices must have same number of rows in %s",
76 :     deparse(sys.call(sys.parent()))),
77 :     call. = FALSE)
78 :     ## return the common nrow()
79 :     da[1]
80 :     }
81 :    
82 :     colCheck <- function(a, b) {
83 :     da <- dim(a)
84 :     db <- dim(b)
85 :     if(da[2] != db[2])
86 :     stop(gettextf("Matrices must have same number of columns in %s",
87 :     deparse(sys.call(sys.parent()))),
88 :     call. = FALSE)
89 :     ## return the common ncol()
90 :     da[2]
91 :     }
92 :    
93 : maechler 1285 ## Note: !isPacked(.) i.e. `full' still contains
94 :     ## ---- "*sy" and "*tr" which have "undefined" lower or upper part
95 : maechler 1227 isPacked <- function(x)
96 :     {
97 : maechler 1472 ## Is 'x' a packed (dense) matrix ?
98 :     is(x, "denseMatrix") &&
99 :     any("x" == slotNames(x)) && length(x@x) < prod(dim(x))
100 : maechler 1227 }
101 :    
102 : maechler 956 emptyColnames <- function(x)
103 :     {
104 :     ## Useful for compact printing of (parts) of sparse matrices
105 : maechler 1238 ## possibly dimnames(x) "==" NULL :
106 : maechler 956 dimnames(x) <- list(dimnames(x)[[1]], rep("", dim(x)[2]))
107 :     x
108 :     }
109 : maechler 908
110 : maechler 919 prTriang <- function(x, digits = getOption("digits"),
111 : maechler 1389 maxp = getOption("max.print"),
112 : maechler 1238 justify = "none", right = TRUE)
113 : maechler 919 {
114 :     ## modeled along stats:::print.dist
115 :     upper <- x@uplo == "U"
116 :    
117 :     m <- as(x, "matrix")
118 :     cf <- format(m, digits = digits, justify = justify)
119 :     if(upper)
120 : maechler 1238 cf[row(cf) > col(cf)] <- "."
121 : maechler 919 else
122 : maechler 1238 cf[row(cf) < col(cf)] <- "."
123 : maechler 1472 if(.isR_24)
124 :     print(cf, quote = FALSE, right = right, max = maxp)
125 :     else print(cf, quote = FALSE, right = right)
126 : maechler 919 invisible(x)
127 :     }
128 :    
129 : maechler 1389 prMatrix <- function(x, digits = getOption("digits"),
130 :     maxp = getOption("max.print")) {
131 : maechler 919 d <- dim(x)
132 :     cl <- class(x)
133 :     cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
134 :     if(prod(d) <= maxp) {
135 : maechler 1238 if(is(x, "triangularMatrix"))
136 : maechler 1472 prTriang(x, digits = digits, maxp = maxp)
137 :     else {
138 :     if(.isR_24)
139 :     print(as(x, "matrix"), digits = digits, max = maxp)
140 :     else print(as(x, "matrix"), digits = digits)
141 :     }
142 : maechler 919 }
143 :     else { ## d[1] > maxp / d[2] >= nr :
144 : maechler 1238 m <- as(x, "matrix")
145 : maechler 919 nr <- maxp %/% d[2]
146 :     n2 <- ceiling(nr / 2)
147 :     print(head(m, max(1, n2)))
148 :     cat("\n ..........\n\n")
149 :     print(tail(m, max(1, nr - n2)))
150 :     }
151 :     ## DEBUG: cat("str(.):\n") ; str(x)
152 :     invisible(x)# as print() S3 methods do
153 :     }
154 :    
155 :     ## For sparseness handling
156 : maechler 1467 ## return a 2-column (i,j) matrix of
157 :     ## 0-based indices of non-zero entries :
158 : maechler 919 non0ind <- function(x) {
159 : maechler 1467
160 : maechler 919 if(is.numeric(x))
161 : maechler 1226 return(if((n <- length(x))) (0:(n-1))[x != 0] else integer(0))
162 :     ## else
163 : maechler 919 stopifnot(is(x, "sparseMatrix"))
164 : maechler 1319 non0.i <- function(M) {
165 :     if(is(M, "TsparseMatrix"))
166 :     return(unique(cbind(M@i,M@j)))
167 :     if(is(M, "pMatrix"))
168 :     return(cbind(seq(length=nrow(M)), M@perm) - 1:1)
169 :     ## else:
170 :     isC <- any("i" == slotNames(M)) # is Csparse (not Rsparse)
171 :     .Call(compressed_non_0_ij, M, isC)
172 :     }
173 :    
174 :     if(is(x, "symmetricMatrix")) { # also get "other" triangle
175 :     ij <- non0.i(x)
176 :     notdiag <- ij[,1] != ij[,2]# but not the diagonals again
177 :     rbind(ij, ij[notdiag, 2:1])
178 :     }
179 : maechler 1389 else if(is(x, "triangularMatrix")) { # check for "U" diag
180 :     if(x@diag == "U") {
181 : maechler 1390 i <- seq(length = dim(x)[1]) - 1:1
182 : maechler 1389 rbind(non0.i(x), cbind(i,i))
183 :     } else non0.i(x)
184 :     }
185 : maechler 1319 else
186 :     non0.i(x)
187 : maechler 1226 }
188 : maechler 954
189 : maechler 1226 ## nr= nrow: since i in {0,1,.., nrow-1} these are 1:1 "decimal" encodings:
190 :     ## Further, these map to and from the usual "Fortran-indexing" (but 0-based)
191 :     encodeInd <- function(ij, nr) ij[,1] + ij[,2] * nr
192 :     decodeInd <- function(code, nr) cbind(code %% nr, code %/% nr)
193 :    
194 :     complementInd <- function(ij, dim)
195 :     {
196 :     ## Purpose: Compute the complement of the 2-column 0-based ij-matrix
197 : maechler 1238 ## but as 1-based indices
198 : maechler 1226 n <- prod(dim)
199 :     if(n == 0) return(integer(0))
200 :     ii <- 1:n
201 :     ii[-(1 + encodeInd(ij, nr = dim[1]))]
202 : maechler 919 }
203 :    
204 : maechler 1226 unionInd <- function(ij1, ij2) unique(rbind(ij1, ij2))
205 :    
206 :     intersectInd <- function(ij1, ij2, nrow) {
207 :     ## from 2-column (i,j) matrices where i in {0,.., nrow-1},
208 :     ## return only the *common* entries
209 :     decodeInd(intersect(encodeInd(ij1, nrow),
210 :     encodeInd(ij2, nrow)), nrow)
211 :     }
212 :    
213 :     WhichintersectInd <- function(ij1, ij2, nrow) {
214 :     ## from 2-column (i,j) matrices where i \in {0,.., nrow-1},
215 :     ## find *where* common entries are in ij1 & ij2
216 :     m1 <- match(encodeInd(ij1, nrow), encodeInd(ij2, nrow))
217 :     ni <- !is.na(m1)
218 :     list(which(ni), m1[ni])
219 :     }
220 :    
221 :    
222 : maechler 925 ### There is a test on this in ../tests/dgTMatrix.R !
223 : maechler 1270
224 : maechler 1331 uniqTsparse <- function(x, class.x = c(class(x))) {
225 :     ## Purpose: produce a *unique* triplet representation:
226 :     ## by having (i,j) sorted and unique
227 :     ## -----------------------------------------------------------
228 :     ## The following is not quite efficient {but easy to program,
229 :     ## and as() are based on C code (all of them?)
230 :     ##
231 :     ## FIXME: Do it fast for the case where 'x' is already 'uniq'
232 : maechler 1270
233 : maechler 1331 switch(class.x,
234 :     "dgTMatrix" = as(as(x, "dgCMatrix"), "dgTMatrix"),
235 :     "dsTMatrix" = as(as(x, "dsCMatrix"), "dsTMatrix"),
236 :     "dtTMatrix" = as(as(x, "dtCMatrix"), "dtTMatrix"),
237 :     ## do we need this for "logical" ones, there's no sum() there!
238 :     "lgTMatrix" = as(as(x, "lgCMatrix"), "lgTMatrix"),
239 :     "lsTMatrix" = as(as(x, "lsCMatrix"), "lsTMatrix"),
240 :     "ltTMatrix" = as(as(x, "ltCMatrix"), "ltTMatrix"),
241 :     ## otherwise:
242 : maechler 1472 stop("not yet implemented for class ", class.x))
243 : maechler 1331 }
244 : maechler 919
245 : maechler 1331 ## Note: maybe, using
246 :     ## ---- xj <- .Call(Matrix_expand_pointers, x@p)
247 :     ## would be slightly more efficient than as( <dgC> , "dgTMatrix")
248 :     ## but really efficient would be to use only one .Call(.) for uniq(.) !
249 :    
250 :     uniq <- function(x) {
251 :     if(is(x, "TsparseMatrix")) uniqTsparse(x) else x
252 :     ## else: not 'Tsparse', i.e. "uniquely" represented in any case
253 : maechler 919 }
254 :    
255 : maechler 1472 asTuniq <- function(x) {
256 :     if(is(x, "TsparseMatrix")) uniqTsparse(x) else as(x,"TsparseMatrix")
257 :     }
258 :    
259 : maechler 919 if(FALSE) ## try an "efficient" version
260 :     uniq_gT <- function(x)
261 :     {
262 :     ## Purpose: produce a *unique* triplet representation:
263 :     ## by having (i,j) sorted and unique
264 : maechler 1226 ## ------------------------------------------------------------------
265 : maechler 919 ## Arguments: a "gT" Matrix
266 :     stopifnot(is(x, "gTMatrix"))
267 :     if((n <- length(x@i)) == 0) return(x)
268 :     ii <- order(x@i, x@j)
269 :     if(any(ii != 1:n)) {
270 : maechler 1238 x@i <- x@i[ii]
271 :     x@j <- x@j[ii]
272 :     x@x <- x@x[ii]
273 : maechler 919 }
274 :     ij <- x@i + nrow(x) * x@j
275 :     if(any(dup <- duplicated(ij))) {
276 :    
277 :     }
278 :     ### We should use a .Call() based utility for this!
279 :    
280 :     }
281 :    
282 : maechler 946 t_geMatrix <- function(x) {
283 :     x@x <- as.vector(t(array(x@x, dim = x@Dim))) # no dimnames here
284 :     x@Dim <- x@Dim[2:1]
285 :     x@Dimnames <- x@Dimnames[2:1]
286 :     ## FIXME: how to set factors?
287 :     x
288 :     }
289 :    
290 :     ## t( [dl]trMatrix ) and t( [dl]syMatrix ) :
291 :     t_trMatrix <- function(x) {
292 :     x@x <- as.vector(t(as(x, "matrix")))
293 :     x@Dim <- x@Dim[2:1]
294 :     x@Dimnames <- x@Dimnames[2:1]
295 :     x@uplo <- if (x@uplo == "U") "L" else "U"
296 :     # and keep x@diag
297 :     x
298 :     }
299 : maechler 956
300 :     fixupDense <- function(m, from) {
301 :     if(is(m, "triangularMatrix")) {
302 : maechler 1238 m@uplo <- from@uplo
303 :     m@diag <- from@diag
304 : maechler 956 } else if(is(m, "symmetricMatrix")) {
305 : maechler 1238 m@uplo <- from@uplo
306 : maechler 956 }
307 :     m
308 :     }
309 :    
310 :     ## -> ./ldenseMatrix.R :
311 :     l2d_Matrix <- function(from) {
312 :     stopifnot(is(from, "lMatrix"))
313 :     fixupDense(new(sub("^l", "d", class(from)),
314 : maechler 1238 x = as.double(from@x),
315 :     Dim = from@Dim, Dimnames = from@Dimnames),
316 :     from)
317 : maechler 1198 ## FIXME: treat 'factors' smartly {not for triangular!}
318 : maechler 956 }
319 :    
320 :     if(FALSE)# unused
321 :     l2d_meth <- function(x) {
322 :     cl <- class(x)
323 :     as(callGeneric(as(x, sub("^l", "d", cl))), cl)
324 :     }
325 :    
326 : maechler 1331 ## return "d" or "l" or "z"
327 :     .M.kind <- function(x, clx = class(x)) {
328 :     if(is.matrix(x)) { ## 'old style matrix'
329 :     if (is.numeric(x)) "d"
330 :     else if(is.logical(x)) "l"
331 :     else if(is.complex(x)) "z"
332 :     else stop("not yet implemented for matrix w/ typeof ", typeof(x))
333 :     }
334 :     else if(extends(clx, "dMatrix")) "d"
335 :     else if(extends(clx, "lMatrix")) "l"
336 :     else if(extends(clx, "zMatrix")) "z"
337 :     else stop(" not yet be implemented for ", clx)
338 :     }
339 :    
340 :     .M.shape <- function(x, clx = class(x)) {
341 :     if(is.matrix(x)) { ## 'old style matrix'
342 :     if (isDiagonal (x)) "d"
343 :     else if(isTriangular(x)) "t"
344 :     else if(isSymmetric (x)) "s"
345 :     else "g" # general
346 :     }
347 :     else if(extends(clx, "diagonalMatrix")) "d"
348 :     else if(extends(clx, "triangularMatrix"))"t"
349 :     else if(extends(clx, "symmetricMatrix")) "s"
350 :     else "g"
351 :     }
352 :    
353 :    
354 : maechler 1329 class2 <- function(cl, kind = "l", do.sub = TRUE) {
355 :     ## Find "corresponding" class; since pos.def. matrices have no pendant:
356 :     if (cl == "dpoMatrix") paste(kind, "syMatrix", sep='')
357 :     else if(cl == "dppMatrix") paste(kind, "spMatrix", sep='')
358 :     else if(do.sub) sub("^d", kind, cl)
359 :     else cl
360 : maechler 1226 }
361 :    
362 :     geClass <- function(x) {
363 : maechler 1331 if (is(x, "dMatrix")) "dgeMatrix"
364 : maechler 1226 else if(is(x, "lMatrix")) "lgeMatrix"
365 : maechler 1331 else if(is(x, "zMatrix")) "zgeMatrix"
366 : maechler 1329 else stop("general Matrix class not yet implemented for ",
367 : maechler 1226 class(x))
368 :     }
369 : maechler 1331
370 :     .dense.prefixes <- c("d" = "di",
371 :     "t" = "tr",
372 :     "s" = "sy",
373 :     "g" = "ge")
374 :    
375 : maechler 1349 .sparse.prefixes <- c("d" = "t", ## map diagonal to triangular
376 :     "t" = "t",
377 :     "s" = "s",
378 :     "g" = "g")
379 : maechler 1331
380 : maechler 1329 ## Used, e.g. after subsetting: Try to use specific class -- if feasible :
381 : maechler 1331 as_dense <- function(x) {
382 :     as(x, paste(.M.kind(x), .dense.prefixes[.M.shape(x)], "Matrix", sep=''))
383 :     }
384 :    
385 :     as_Csparse <- function(x) {
386 : maechler 1349 as(x, paste(.M.kind(x), .sparse.prefixes[.M.shape(x)], "CMatrix", sep=''))
387 : maechler 1331 }
388 : maechler 1349 as_Rsparse <- function(x) {
389 :     as(x, paste(.M.kind(x), .sparse.prefixes[.M.shape(x)], "RMatrix", sep=''))
390 :     }
391 :     as_Tsparse <- function(x) {
392 :     as(x, paste(.M.kind(x), .sparse.prefixes[.M.shape(x)], "TMatrix", sep=''))
393 :     }
394 : maechler 1331
395 : maechler 1329 as_geClass <- function(x, cl) {
396 : maechler 1331 if (extends(cl, "diagonalMatrix") && isDiagonal(x))
397 :     as(x, cl)
398 : maechler 1357 else if(extends(cl, "symmetricMatrix") && isSymmetric(x)) {
399 :     kind <- .M.kind(x)
400 : maechler 1331 as(x, class2(cl, kind, do.sub= kind != "d"))
401 : maechler 1357 } else if(extends(cl, "triangularMatrix") && isTriangular(x))
402 : maechler 1331 as(x, cl)
403 :     else
404 :     as(x, paste(.M.kind(x), "geMatrix", sep=''))
405 :     }
406 : maechler 1226
407 : maechler 1331 as_CspClass <- function(x, cl) {
408 :     if ((extends(cl, "diagonalMatrix") && isDiagonal(x)) ||
409 :     (extends(cl, "symmetricMatrix") && isSymmetric(x)) ||
410 :     (extends(cl, "triangularMatrix")&& isTriangular(x)))
411 :     as(x, cl)
412 :     else as(x, paste(.M.kind(x), "gCMatrix", sep=''))
413 : maechler 1329 }
414 :    
415 : maechler 1331
416 : maechler 956 ## -> ./ddenseMatrix.R :
417 :     d2l_Matrix <- function(from) {
418 :     stopifnot(is(from, "dMatrix"))
419 : maechler 1226 fixupDense(new(sub("^d", "l", class(from)), # no need for dClass2 here
420 : maechler 1238 Dim = from@Dim, Dimnames = from@Dimnames),
421 :     from)
422 : maechler 1198 ## FIXME: treat 'factors' smartly {not for triangular!}
423 : maechler 956 }
424 : maechler 973
425 :    
426 :     try_as <- function(x, classes, tryAnyway = FALSE) {
427 :     if(!tryAnyway && !is(x, "Matrix"))
428 : maechler 1238 return(x)
429 : maechler 973 ## else
430 :     ok <- canCoerce(x, classes[1])
431 :     while(!ok && length(classes <- classes[-1])) {
432 : maechler 1238 ok <- canCoerce(x, classes[1])
433 : maechler 973 }
434 :     if(ok) as(x, classes[1]) else x
435 :     }
436 :    
437 :    
438 : maechler 1238 ## For *dense* matrices
439 :     isTriMat <- function(object, upper = NA) {
440 : maechler 1174 ## pretest: is it square?
441 :     d <- dim(object)
442 :     if(d[1] != d[2]) return(FALSE)
443 :     ## else slower test
444 :     if(!is.matrix(object))
445 : maechler 1226 object <- as(object,"matrix")
446 :     if(is.na(upper)) {
447 : maechler 1467 if(all0(object[lower.tri(object)]))
448 : maechler 1226 structure(TRUE, kind = "U")
449 : maechler 1467 else if(all0(object[upper.tri(object)]))
450 : maechler 1226 structure(TRUE, kind = "L")
451 :     else FALSE
452 :     } else if(upper)
453 : maechler 1467 all0(object[lower.tri(object)])
454 : maechler 1226 else ## upper is FALSE
455 : maechler 1467 all0(object[upper.tri(object)])
456 : maechler 1174 }
457 :    
458 : maechler 1238 ## For Csparse matrices
459 :     isTriC <- function(x, upper = NA) {
460 :     ## pretest: is it square?
461 :     d <- dim(x)
462 :     if(d[1] != d[2]) return(FALSE)
463 :     ## else
464 :     if(d[1] == 0) return(TRUE)
465 : maechler 1315 ni <- 1:d[2]
466 : maechler 1238 ## the row indices split according to column:
467 :     ilist <- split(x@i, factor(rep.int(ni, diff(x@p)), levels= ni))
468 :     lil <- unlist(lapply(ilist, length), use.names = FALSE)
469 :     if(any(lil == 0)) {
470 :     pos <- lil > 0
471 :     if(!any(pos)) ## matrix of all 0's
472 :     return(TRUE)
473 :     ilist <- ilist[pos]
474 :     ni <- ni[pos]
475 :     }
476 : maechler 1315 ni0 <- ni - 1:1 # '0-based ni'
477 : maechler 1238 if(is.na(upper)) {
478 : maechler 1315 if(all(sapply(ilist, max, USE.NAMES = FALSE) <= ni0))
479 : maechler 1238 structure(TRUE, kind = "U")
480 : maechler 1315 else if(all(sapply(ilist, min, USE.NAMES = FALSE) >= ni0))
481 : maechler 1238 structure(TRUE, kind = "L")
482 :     else FALSE
483 :     } else if(upper) {
484 : maechler 1315 all(sapply(ilist, max, USE.NAMES = FALSE) <= ni0)
485 : maechler 1238 } else { ## 'lower'
486 : maechler 1315 all(sapply(ilist, min, USE.NAMES = FALSE) >= ni0)
487 : maechler 1238 }
488 :     }
489 :    
490 : maechler 1174 .is.diagonal <- function(object) {
491 : maechler 1357 ## "matrix" or "denseMatrix" (but not "diagonalMatrix")
492 : maechler 1174 d <- dim(object)
493 :     if(d[1] != (n <- d[2])) FALSE
494 : maechler 1357 else if(is.matrix(object))
495 :     ## requires that "vector-indexing" works for 'object' :
496 : maechler 1467 all0(object[rep(c(FALSE, rep.int(TRUE,n)), length = n^2)])
497 : maechler 1357 else ## "denseMatrix" -- packed or unpacked
498 :     if(is(object, "generalMatrix")) # "dge", "lge", ...
499 : maechler 1467 all0(object@x[rep(c(FALSE, rep.int(TRUE,n)), length = n^2)])
500 : maechler 1357 else { ## "dense" but not {diag, general}, i.e. triangular or symmetric:
501 :     ## -> has 'uplo' differentiate between packed and unpacked
502 :    
503 :     ### .......... FIXME ...............
504 :    
505 :     packed <- isPacked(object)
506 :     if(object@uplo == "U") {
507 :     } else { ## uplo == "L"
508 :     }
509 :    
510 :     ### very cheap workaround
511 : maechler 1467 all0(as.matrix(object)[rep(c(FALSE, rep.int(TRUE,n)), length = n^2)])
512 : maechler 1357 }
513 : maechler 1174 }
514 : maechler 1253
515 : maechler 1357
516 : maechler 1253 diagU2N <- function(x)
517 :     {
518 :     ## Purpose: Transform a *unit diagonal* triangular matrix
519 :     ## into one with explicit diagonal entries '1'
520 :     xT <- as(x, "dgTMatrix")
521 :     ## leave it as T* - the caller can always coerce to C* if needed:
522 :     new("dtTMatrix", x = xT@x, i = xT@i, j = xT@j, Dim = x@Dim,
523 :     Dimnames = x@Dimnames, uplo = x@uplo, diag = "N")
524 :     }
525 : maechler 1290
526 : maechler 1349 ## FIXME: this should probably be dropped / replaced by as_Csparse
527 : maechler 1295 .as.dgC.Fun <- function(x, na.rm = FALSE, dims = 1) {
528 :     x <- as(x, "dgCMatrix")
529 :     callGeneric()
530 :     }
531 :    
532 :     .as.dgT.Fun <- function(x, na.rm = FALSE, dims = 1) {
533 : maechler 1349 ## used e.g. inside colSums() etc methods
534 : maechler 1295 x <- as(x, "dgTMatrix")
535 :     callGeneric()
536 :     }
537 :    
538 :    
539 : maechler 1290 ### Fast much simplified version of tapply()
540 :     tapply1 <- function (X, INDEX, FUN = NULL, ..., simplify = TRUE) {
541 :     sapply(split(X, INDEX), FUN, ..., simplify = simplify, USE.NAMES = FALSE)
542 :     }
543 :    
544 :     ## tapply.x <- function (X, n, INDEX, FUN = NULL, ..., simplify = TRUE) {
545 :     ## tapply1(X, factor(INDEX, 0:(n-1)), FUN = FUN, ..., simplify = simplify)
546 :     ## }
547 :    

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