SCM

SCM Repository

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

Annotation of /pkg/Matrix/R/diagMatrix.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2106 - (view) (download)
Original Path: pkg/R/diagMatrix.R

1 : maechler 1617 #### All methods for "diagonalMatrix" and its subclasses,
2 :     #### currently "ddiMatrix", "ldiMatrix"
3 :    
4 : maechler 1109 ## Purpose: Constructor of diagonal matrices -- ~= diag() ,
5 :     ## but *not* diag() extractor!
6 :     Diagonal <- function(n, x = NULL)
7 :     {
8 : maechler 1575 ## Allow Diagonal(4) and Diagonal(x=1:5)
9 : maechler 1109 if(missing(n))
10 : maechler 1575 n <- length(x)
11 : maechler 1109 else {
12 : maechler 1575 stopifnot(length(n) == 1, n == as.integer(n), n >= 0)
13 :     n <- as.integer(n)
14 : maechler 1109 }
15 :    
16 : maechler 1654 if(missing(x)) ## unit diagonal matrix
17 : maechler 1575 new("ddiMatrix", Dim = c(n,n), diag = "U")
18 : maechler 1109 else {
19 : maechler 1575 stopifnot(length(x) == n)
20 :     if(is.logical(x))
21 :     cl <- "ldiMatrix"
22 :     else if(is.numeric(x)) {
23 :     cl <- "ddiMatrix"
24 :     x <- as.numeric(x)
25 :     }
26 :     else if(is.complex(x)) {
27 :     cl <- "zdiMatrix" # will not yet work
28 :     } else stop("'x' has invalid data type")
29 :     new(cl, Dim = c(n,n), diag = "N", x = x)
30 : maechler 1109 }
31 :     }
32 :    
33 : maechler 1617 ### This is modified from a post of Bert Gunter to R-help on 1 Sep 2005.
34 :     ### Bert's code built on a post by Andy Liaw who most probably was influenced
35 :     ### by earlier posts, notably one by Scott Chasalow on S-news, 16 Jan 2002
36 :     ### who posted his bdiag() function written in December 1995.
37 :    
38 :     bdiag <- function(...) {
39 :     if(nargs() == 0) return(new("dgCMatrix"))
40 :     ## else :
41 :     mlist <- if (nargs() == 1) as.list(...) else list(...)
42 :     dims <- sapply(mlist, dim)
43 :     ## make sure we had all matrices:
44 :     if(!(is.matrix(dims) && nrow(dims) == 2))
45 :     stop("some arguments are not matrices")
46 : maechler 1845 csdim <- rbind(rep.int(0L, 2),
47 : maechler 1617 apply(sapply(mlist, dim), 1, cumsum))
48 :     ret <- new("dgTMatrix", Dim = as.integer(csdim[nrow(csdim),]))
49 :     add1 <- matrix(1:0, 2,2)
50 : maechler 1654 for(i in seq_along(mlist)) {
51 : maechler 1617 indx <- apply(csdim[i:(i+1),] + add1, 2, function(n) n[1]:n[2])
52 :     if(is.null(dim(indx))) ## non-square matrix
53 :     ret[indx[[1]],indx[[2]]] <- mlist[[i]]
54 :     else ## square matrix
55 :     ret[indx[,1],indx[,2]] <- mlist[[i]]
56 :     }
57 :     ## slightly debatable if we really should return Csparse.. :
58 :     as(ret, "CsparseMatrix")
59 :     }
60 :    
61 : maechler 1845 diag2tT <- function(from) {
62 :     i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L
63 : maechler 1654 new(paste(.M.kind(from), "tTMatrix", sep=''),
64 :     diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,
65 :     x = from@x, # <- ok for diag = "U" and "N" (!)
66 :     i = i, j = i)
67 :     }
68 : maechler 1109
69 : maechler 1845 diag2sT <- function(from) { # to symmetric Tsparse
70 :     i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L
71 :     new(paste(.M.kind(from), "sTMatrix", sep=''),
72 :     Dim = from@Dim, Dimnames = from@Dimnames,
73 :     x = from@x, i = i, j = i)
74 :     }
75 :    
76 :     setAs("diagonalMatrix", "triangularMatrix", diag2tT)
77 :     setAs("diagonalMatrix", "sparseMatrix", diag2tT)
78 : maechler 1805 ## needed too (otherwise <dense> -> Tsparse is taken):
79 : maechler 1845 setAs("diagonalMatrix", "TsparseMatrix", diag2tT)
80 : maechler 1654 ## is better than this:
81 :     ## setAs("diagonalMatrix", "sparseMatrix",
82 :     ## function(from)
83 :     ## as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))
84 :     setAs("diagonalMatrix", "CsparseMatrix",
85 : maechler 1845 function(from) as(diag2tT(from), "CsparseMatrix"))
86 : maechler 1654
87 : maechler 1845 setAs("diagonalMatrix", "symmetricMatrix", diag2sT)
88 :    
89 : maechler 1109 setAs("diagonalMatrix", "matrix",
90 :     function(from) {
91 :     n <- from@Dim[1]
92 :     diag(x = if(from@diag == "U") { if(is.numeric(from@x)) 1. else TRUE
93 :     } else from@x,
94 :     nrow = n, ncol = n)
95 :     })
96 :    
97 : maechler 2098 setMethod("as.vector", signature(x = "diagonalMatrix", mode="missing"),
98 :     function(x, mode) {
99 :     n <- x@Dim[1]
100 :     mod <- mode(x@x)
101 :     r <- vector(mod, length = n^2)
102 :     if(n)
103 :     r[1 + 0:(n - 1) * (n + 1)] <-
104 :     if(x@diag == "U")
105 :     switch(mod, "integer"= 1L,
106 :     "numeric"= 1, "logical"= TRUE)
107 :     else x@x
108 :     r
109 :     })
110 :    
111 : maechler 1654 setAs("diagonalMatrix", "generalMatrix", # prefer sparse:
112 :     function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))
113 : maechler 1174
114 : maechler 1655 .diag.x <- function(m) {
115 :     if(m@diag == "U")
116 :     rep.int(if(is.numeric(m@x)) 1. else TRUE,
117 :     m@Dim[1])
118 :     else m@x
119 :     }
120 :    
121 :     .diag.2N <- function(m) {
122 :     if(m@diag == "U") m@diag <- "N"
123 :     m
124 :     }
125 :    
126 : maechler 1654 ## given the above, the following 4 coercions should be all unneeded;
127 :     ## we prefer triangular to general:
128 : maechler 1295 setAs("ddiMatrix", "dgTMatrix",
129 :     function(from) {
130 : maechler 1654 .Deprecated("as(, \"sparseMatrix\")")
131 : maechler 1295 n <- from@Dim[1]
132 : maechler 1845 i <- seq_len(n) - 1L
133 : maechler 1655 new("dgTMatrix", i = i, j = i, x = .diag.x(from),
134 : maechler 1295 Dim = c(n,n), Dimnames = from@Dimnames) })
135 :    
136 :     setAs("ddiMatrix", "dgCMatrix",
137 : maechler 1655 function(from) as(as(from, "sparseMatrix"), "dgCMatrix"))
138 : maechler 1295
139 :     setAs("ldiMatrix", "lgTMatrix",
140 :     function(from) {
141 : maechler 1654 .Deprecated("as(, \"sparseMatrix\")")
142 : maechler 1295 n <- from@Dim[1]
143 : maechler 1575 if(from@diag == "U") { # unit-diagonal
144 :     x <- rep.int(TRUE, n)
145 : maechler 1845 i <- seq_len(n) - 1L
146 : maechler 1575 } else { # "normal"
147 :     nz <- nz.NA(from@x, na. = TRUE)
148 :     x <- from@x[nz]
149 : maechler 1845 i <- which(nz) - 1L
150 : maechler 1575 }
151 :     new("lgTMatrix", i = i, j = i, x = x,
152 : maechler 1295 Dim = c(n,n), Dimnames = from@Dimnames) })
153 :    
154 :     setAs("ldiMatrix", "lgCMatrix",
155 :     function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))
156 :    
157 :    
158 : maechler 1447 if(FALSE) # now have faster "ddense" -> "dge"
159 : maechler 1174 setAs("ddiMatrix", "dgeMatrix",
160 :     function(from) as(as(from, "matrix"), "dgeMatrix"))
161 :    
162 : maechler 1109 setAs("matrix", "diagonalMatrix",
163 :     function(from) {
164 : maechler 1295 d <- dim(from)
165 : maechler 1109 if(d[1] != (n <- d[2])) stop("non-square matrix")
166 :     if(any(from[row(from) != col(from)] != 0))
167 :     stop("has non-zero off-diagonal entries")
168 : maechler 1295 x <- diag(from)
169 :     if(is.logical(x)) {
170 :     cl <- "ldiMatrix"
171 :     uni <- all(x)
172 :     } else {
173 :     cl <- "ddiMatrix"
174 :     uni <- all(x == 1)
175 :     storage.mode(x) <- "double"
176 : maechler 1575 } ## TODO: complex
177 : maechler 1295 new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",
178 :     x = if(uni) x[FALSE] else x)
179 : maechler 1109 })
180 :    
181 :     ## ``generic'' coercion to diagonalMatrix : build on isDiagonal() and diag()
182 :     setAs("Matrix", "diagonalMatrix",
183 :     function(from) {
184 :     d <- dim(from)
185 :     if(d[1] != (n <- d[2])) stop("non-square matrix")
186 :     if(!isDiagonal(from)) stop("matrix is not diagonal")
187 :     ## else:
188 :     x <- diag(from)
189 :     if(is.logical(x)) {
190 :     cl <- "ldiMatrix"
191 :     uni <- all(x)
192 :     } else {
193 :     cl <- "ddiMatrix"
194 :     uni <- all(x == 1)
195 :     storage.mode(x) <- "double"
196 :     }
197 :     new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",
198 :     x = if(uni) x[FALSE] else x)
199 :     })
200 :    
201 : maechler 1708
202 :     setMethod("diag", signature(x = "diagonalMatrix"),
203 : maechler 2052 function(x = 1, nrow, ncol) .diag.x(x))
204 : maechler 1708
205 : maechler 1799
206 : maechler 2098 subDiag <- function(x, i, j, ..., drop) {
207 : maechler 1799 x <- as(x, "sparseMatrix")
208 :     x <- if(missing(i))
209 :     x[, j, drop=drop]
210 :     else if(missing(j))
211 :     x[i, , drop=drop]
212 :     else
213 :     x[i,j, drop=drop]
214 :     if(isDiagonal(x)) as(x, "diagonalMatrix") else x
215 :     }
216 :    
217 :     setMethod("[", signature(x = "diagonalMatrix", i = "index",
218 :     j = "index", drop = "logical"), subDiag)
219 :     setMethod("[", signature(x = "diagonalMatrix", i = "index",
220 :     j = "missing", drop = "logical"),
221 : maechler 2098 function(x, i, j, ..., drop) subDiag(x, i=i, drop=drop))
222 : maechler 1799 setMethod("[", signature(x = "diagonalMatrix", i = "missing",
223 :     j = "index", drop = "logical"),
224 : maechler 2098 function(x, i, j, ..., drop) subDiag(x, j=j, drop=drop))
225 : maechler 1799
226 : maechler 1617 ## When you assign to a diagonalMatrix, the result should be
227 : maechler 1708 ## diagonal or sparse ---
228 :     ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch
229 : maechler 2098 ## Only(?) current bug: x[i] <- value is wrong when i is *vector*
230 :     replDiag <- function(x, i, j, ..., value) {
231 : maechler 1710 x <- as(x, "sparseMatrix")
232 :     if(missing(i))
233 :     x[, j] <- value
234 : maechler 2098 else if(missing(j)) { ## x[i , ] <- v *OR* x[i] <- v
235 :     na <- nargs()
236 :     ## message("diagnosing replDiag() -- nargs()= ", na)
237 :     if(na == 4)
238 :     x[i, ] <- value
239 :     else if(na == 3)
240 :     x[i] <- value
241 :     else stop("Internal bug: nargs()=",na,"; please report")
242 :     } else
243 : maechler 1710 x[i,j] <- value
244 :     if(isDiagonal(x)) as(x, "diagonalMatrix") else x
245 :     }
246 : maechler 1617
247 : maechler 1710 setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
248 :     j = "index", value = "replValue"), replDiag)
249 : maechler 2098
250 : maechler 1710 setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
251 :     j = "missing", value = "replValue"),
252 : maechler 2098 function(x,i,j, ..., value) {
253 :     ## message("before replDiag() -- nargs()= ", nargs())
254 :     if(nargs() == 3)
255 :     replDiag(x, i=i, value=value)
256 :     else ## nargs() == 4 :
257 :     replDiag(x, i=i, , value=value)
258 :     })
259 :    
260 : maechler 2096 setReplaceMethod("[", signature(x = "diagonalMatrix", i = "matrix", # 2-col.matrix
261 :     j = "missing", value = "replValue"),
262 : maechler 2098 function(x,i,j, ..., value) {
263 : maechler 2096 if(ncol(i) == 2) {
264 :     if(all((ii <- i[,1]) == i[,2])) { # replace in diagonal only
265 :     x@x[ii] <- value
266 :     x
267 :     } else { ## no longer diagonal, but remain sparse:
268 :     x <- as(x, "sparseMatrix")
269 :     x[i] <- value
270 :     x
271 :     }
272 :     }
273 :     else { # behave as "base R": use as if vector
274 :     x <- as(x, "matrix")
275 :     x[i] <- value
276 :     Matrix(x)
277 :     }
278 :     })
279 :    
280 : maechler 1710 setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing",
281 :     j = "index", value = "replValue"),
282 : maechler 2098 function(x,i,j, ..., value) replDiag(x, j=j, value=value))
283 : maechler 1710
284 :    
285 : maechler 1109 setMethod("t", signature(x = "diagonalMatrix"),
286 :     function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })
287 :    
288 : maechler 1331 setMethod("isDiagonal", signature(object = "diagonalMatrix"),
289 :     function(object) TRUE)
290 :     setMethod("isTriangular", signature(object = "diagonalMatrix"),
291 :     function(object) TRUE)
292 : maechler 1109 setMethod("isSymmetric", signature(object = "diagonalMatrix"),
293 :     function(object) TRUE)
294 :    
295 : maechler 1654 setMethod("chol", signature(x = "ddiMatrix"),# pivot = "ANY"
296 :     function(x, pivot) {
297 :     if(any(x@x < 0)) stop("chol() is undefined for diagonal matrix with negative entries")
298 :     x@x <- sqrt(x@x)
299 :     x
300 :     })
301 :     ## chol(L) is L for logical diagonal:
302 :     setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot) x)
303 :    
304 : maechler 1109 ## Basic Matrix Multiplication {many more to add}
305 : maechler 1654 ## ---------------------
306 :     ## Note that "ldi" logical are treated as numeric
307 : maechler 1109 diagdiagprod <- function(x, y) {
308 :     if(any(dim(x) != dim(y))) stop("non-matching dimensions")
309 :     if(x@diag != "U") {
310 : maechler 1654 if(y@diag != "U") {
311 :     nx <- x@x * y@x
312 :     if(is.numeric(nx) && !is.numeric(x@x))
313 :     x <- as(x, "dMatrix")
314 :     x@x <- as.numeric(nx)
315 :     }
316 :     return(x)
317 : maechler 1109 } else ## x is unit diagonal
318 :     return(y)
319 :     }
320 :    
321 : maechler 1654 setMethod("%*%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
322 : maechler 1109 diagdiagprod, valueClass = "ddiMatrix")
323 :    
324 : maechler 1654 formals(diagdiagprod) <- alist(x=, y=x)
325 :     setMethod("crossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
326 : maechler 1109 diagdiagprod, valueClass = "ddiMatrix")
327 : maechler 1654 setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
328 : maechler 1109 diagdiagprod, valueClass = "ddiMatrix")
329 : maechler 1654 setMethod("crossprod", signature(x = "diagonalMatrix", y = "missing"),
330 :     diagdiagprod, valueClass = "ddiMatrix")
331 :     setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "missing"),
332 :     diagdiagprod, valueClass = "ddiMatrix")
333 : maechler 1109
334 :    
335 :     diagmatprod <- function(x, y) {
336 :     dx <- dim(x)
337 :     dy <- dim(y)
338 :     if(dx[2] != dy[1]) stop("non-matching dimensions")
339 :     n <- dx[1]
340 :     as(if(x@diag == "U") y else x@x * y, "Matrix")
341 :     }
342 :    
343 :     setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"),
344 : maechler 1654 diagmatprod)
345 : maechler 1109 formals(diagmatprod) <- alist(x=, y=NULL)
346 :     setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),
347 : maechler 1654 diagmatprod)
348 :     setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "matrix"),
349 :     diagmatprod)
350 : maechler 1109
351 :     diagdgeprod <- function(x, y) {
352 :     dx <- dim(x)
353 :     dy <- dim(y)
354 :     if(dx[2] != dy[1]) stop("non-matching dimensions")
355 :     if(x@diag != "U")
356 :     y@x <- x@x * y@x
357 :     y
358 :     }
359 :     setMethod("%*%", signature(x = "diagonalMatrix", y = "dgeMatrix"),
360 :     diagdgeprod, valueClass = "dgeMatrix")
361 :     formals(diagdgeprod) <- alist(x=, y=NULL)
362 :     setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"),
363 :     diagdgeprod, valueClass = "dgeMatrix")
364 :    
365 :     setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"),
366 :     function(x, y) {
367 : maechler 1635 dx <- dim(x)
368 :     dy <- dim(y)
369 :     if(dx[2] != dy[1]) stop("non-matching dimensions")
370 :     as(if(y@diag == "U") x else x * rep(y@x, each = dx[1]), "Matrix")
371 :     })
372 : maechler 1109
373 :     setMethod("%*%", signature(x = "dgeMatrix", y = "diagonalMatrix"),
374 :     function(x, y) {
375 : maechler 1635 dx <- dim(x)
376 :     dy <- dim(y)
377 :     if(dx[2] != dy[1]) stop("non-matching dimensions")
378 :     if(y@diag == "N")
379 :     x@x <- x@x * rep(y@x, each = dx[1])
380 :     x
381 :     })
382 : maechler 1109
383 : maechler 1295 ## crossprod {more of these}
384 : maechler 1109
385 : maechler 1295 ## tcrossprod --- all are not yet there: do the dense ones here:
386 : maechler 1109
387 : maechler 1295 ## FIXME:
388 :     ## setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "denseMatrix"),
389 :     ## function(x, y = NULL) {
390 :     ## })
391 : maechler 1109
392 : maechler 1295 ## setMethod("tcrossprod", signature(x = "denseMatrix", y = "diagonalMatrix"),
393 :     ## function(x, y = NULL) {
394 :     ## })
395 : maechler 1109
396 : maechler 1799 setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
397 :     function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
398 : maechler 1295
399 : maechler 1799 setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
400 :     function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
401 :    
402 :     setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
403 :     function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
404 :    
405 :     setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
406 :     function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
407 :    
408 :    
409 :     ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
410 :     setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
411 :     function(x, y) as(x, "sparseMatrix") %*% y)
412 :     ## NB: The previous is *not* triggering for "ddi" o "dgC" (= distance 3)
413 :     ## since there's a "ddense" o "Csparse" at dist. 2 => triggers first.
414 :     ## ==> do this:
415 :     setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
416 :     function(x, y) as(x, "CsparseMatrix") %*% y)
417 :     setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
418 :     function(x, y) x %*% as(y, "CsparseMatrix"))
419 :     ## NB: this is *not* needed for Tsparse & Rsparse
420 :     ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
421 :     ## do indeed work by going through sparse (and *not* ddense)!
422 :    
423 :     setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
424 :     function(x, y) x %*% as(y, "sparseMatrix"))
425 :    
426 :    
427 :     setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),
428 :     function(a, b, ...) {
429 :     a@x <- 1/ a@x
430 :     a@Dimnames <- a@Dimnames[2:1]
431 :     a
432 :     })
433 :    
434 :     solveDiag <- function(a, b, ...) {
435 :     if((n <- a@Dim[1]) != nrow(b))
436 :     stop("incompatible matrix dimensions")
437 :     ## trivially invert a 'in place' and multiply:
438 :     a@x <- 1/ a@x
439 :     a@Dimnames <- a@Dimnames[2:1]
440 :     a %*% b
441 :     }
442 :     setMethod("solve", signature(a = "diagonalMatrix", b = "matrix"),
443 :     solveDiag)
444 :     setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),
445 :     solveDiag)
446 :    
447 : maechler 2106 ## Schur() ---> ./eigen.R
448 : maechler 1799
449 :    
450 :    
451 : maechler 1654 ### ---------------- diagonal o sparse -----------------------------
452 : maechler 1295
453 : maechler 1655
454 :     ## Use function for several signatures, in order to evade
455 :     ## ambiguous dispatch for "ddi", since there's also Arith(ddense., ddense.)
456 :     diagOdiag <- function(e1,e2) { # result should also be diagonal
457 :     r <- callGeneric(.diag.x(e1), .diag.x(e2)) # error if not "compatible"
458 :     if(is.numeric(r)) {
459 :     if(is.numeric(e2@x)) {
460 :     e2@x <- r; return(.diag.2N(e2)) }
461 :     if(!is.numeric(e1@x))
462 :     ## e.g. e1, e2 are logical;
463 :     e1 <- as(e1, "dMatrix")
464 :     }
465 :     else if(is.logical(r))
466 :     e1 <- as(e1, "lMatrix")
467 :     else stop("intermediate 'r' is of type", typeof(r))
468 :     e1@x <- r
469 :     .diag.2N(e1)
470 :     }
471 :    
472 :     setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "diagonalMatrix"),
473 :     diagOdiag)
474 :     ## These two are just for method disambiguation:
475 :     setMethod("Ops", signature(e1 = "ddiMatrix", e2 = "diagonalMatrix"),
476 :     diagOdiag)
477 :     setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ddiMatrix"),
478 :     diagOdiag)
479 :    
480 : maechler 1845 ## FIXME: diagonal o triangular |--> triangular
481 :     ## ----- diagonal o symmetric |--> symmetric
482 :     ## {also when other is sparse: do these "here" --
483 :     ## before conversion to sparse, since that loses "diagonality"}
484 :    
485 : maechler 1655 ## For almost everything else, diag* shall be treated "as sparse" :
486 : maechler 1295 ## These are cheap implementations via coercion
487 :    
488 : maechler 1655 ## for disambiguation
489 : maechler 1654 setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "sparseMatrix"),
490 :     function(e1,e2) callGeneric(as(e1, "sparseMatrix"), e2))
491 :     setMethod("Ops", signature(e1 = "sparseMatrix", e2 = "diagonalMatrix"),
492 :     function(e1,e2) callGeneric(e1, as(e2, "sparseMatrix")))
493 : maechler 1655 ## in general:
494 :     setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ANY"),
495 :     function(e1,e2) callGeneric(as(e1,"sparseMatrix"), e2))
496 :     setMethod("Ops", signature(e1 = "ANY", e2 = "diagonalMatrix"),
497 :     function(e1,e2) callGeneric(e1, as(e2,"sparseMatrix")))
498 : maechler 1654
499 : maechler 1655
500 :    
501 : maechler 1109 ## similar to prTriang() in ./Auxiliaries.R :
502 :     prDiag <-
503 :     function(x, digits = getOption("digits"), justify = "none", right = TRUE)
504 :     {
505 :     cf <- array(".", dim = x@Dim, dimnames = x@Dimnames)
506 :     cf[row(cf) == col(cf)] <-
507 :     sapply(diag(x), format, digits = digits, justify = justify)
508 :     print(cf, quote = FALSE, right = right)
509 :     invisible(x)
510 :     }
511 :    
512 :     setMethod("show", signature(object = "diagonalMatrix"),
513 : maechler 1592 function(object) {
514 :     d <- dim(object)
515 :     cl <- class(object)
516 :     cat(sprintf('%d x %d diagonal matrix of class "%s"\n',
517 :     d[1], d[2], cl))
518 :     prDiag(object)
519 :     })

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