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 1748 - (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 :     csdim <- rbind(rep.int(0:0, 2),
47 :     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 1654 diag2T <- function(from) {
62 :     i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1:1
63 :     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 1654 setAs("diagonalMatrix", "triangularMatrix", diag2T)
70 :     setAs("diagonalMatrix", "sparseMatrix", diag2T)
71 :     ## is better than this:
72 :     ## setAs("diagonalMatrix", "sparseMatrix",
73 :     ## function(from)
74 :     ## as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))
75 :     setAs("diagonalMatrix", "CsparseMatrix",
76 :     function(from) as(diag2T(from), "CsparseMatrix"))
77 :    
78 : maechler 1109 setAs("diagonalMatrix", "matrix",
79 :     function(from) {
80 :     n <- from@Dim[1]
81 :     diag(x = if(from@diag == "U") { if(is.numeric(from@x)) 1. else TRUE
82 :     } else from@x,
83 :     nrow = n, ncol = n)
84 :     })
85 :    
86 : maechler 1654 setAs("diagonalMatrix", "generalMatrix", # prefer sparse:
87 :     function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))
88 : maechler 1174
89 : maechler 1655 .diag.x <- function(m) {
90 :     if(m@diag == "U")
91 :     rep.int(if(is.numeric(m@x)) 1. else TRUE,
92 :     m@Dim[1])
93 :     else m@x
94 :     }
95 :    
96 :     .diag.2N <- function(m) {
97 :     if(m@diag == "U") m@diag <- "N"
98 :     m
99 :     }
100 :    
101 : maechler 1654 ## given the above, the following 4 coercions should be all unneeded;
102 :     ## we prefer triangular to general:
103 : maechler 1295 setAs("ddiMatrix", "dgTMatrix",
104 :     function(from) {
105 : maechler 1654 .Deprecated("as(, \"sparseMatrix\")")
106 : maechler 1295 n <- from@Dim[1]
107 : maechler 1654 i <- seq_len(n) - 1:1
108 : maechler 1655 new("dgTMatrix", i = i, j = i, x = .diag.x(from),
109 : maechler 1295 Dim = c(n,n), Dimnames = from@Dimnames) })
110 :    
111 :     setAs("ddiMatrix", "dgCMatrix",
112 : maechler 1655 function(from) as(as(from, "sparseMatrix"), "dgCMatrix"))
113 : maechler 1295
114 :     setAs("ldiMatrix", "lgTMatrix",
115 :     function(from) {
116 : maechler 1654 .Deprecated("as(, \"sparseMatrix\")")
117 : maechler 1295 n <- from@Dim[1]
118 : maechler 1575 if(from@diag == "U") { # unit-diagonal
119 :     x <- rep.int(TRUE, n)
120 : maechler 1654 i <- seq_len(n) - 1:1
121 : maechler 1575 } else { # "normal"
122 :     nz <- nz.NA(from@x, na. = TRUE)
123 :     x <- from@x[nz]
124 :     i <- which(nz) - 1:1
125 :     }
126 :     new("lgTMatrix", i = i, j = i, x = x,
127 : maechler 1295 Dim = c(n,n), Dimnames = from@Dimnames) })
128 :    
129 :     setAs("ldiMatrix", "lgCMatrix",
130 :     function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))
131 :    
132 :    
133 : maechler 1447 if(FALSE) # now have faster "ddense" -> "dge"
134 : maechler 1174 setAs("ddiMatrix", "dgeMatrix",
135 :     function(from) as(as(from, "matrix"), "dgeMatrix"))
136 :    
137 : maechler 1109 setAs("matrix", "diagonalMatrix",
138 :     function(from) {
139 : maechler 1295 d <- dim(from)
140 : maechler 1109 if(d[1] != (n <- d[2])) stop("non-square matrix")
141 :     if(any(from[row(from) != col(from)] != 0))
142 :     stop("has non-zero off-diagonal entries")
143 : maechler 1295 x <- diag(from)
144 :     if(is.logical(x)) {
145 :     cl <- "ldiMatrix"
146 :     uni <- all(x)
147 :     } else {
148 :     cl <- "ddiMatrix"
149 :     uni <- all(x == 1)
150 :     storage.mode(x) <- "double"
151 : maechler 1575 } ## TODO: complex
152 : maechler 1295 new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",
153 :     x = if(uni) x[FALSE] else x)
154 : maechler 1109 })
155 :    
156 :     ## ``generic'' coercion to diagonalMatrix : build on isDiagonal() and diag()
157 :     setAs("Matrix", "diagonalMatrix",
158 :     function(from) {
159 :     d <- dim(from)
160 :     if(d[1] != (n <- d[2])) stop("non-square matrix")
161 :     if(!isDiagonal(from)) stop("matrix is not diagonal")
162 :     ## else:
163 :     x <- diag(from)
164 :     if(is.logical(x)) {
165 :     cl <- "ldiMatrix"
166 :     uni <- all(x)
167 :     } else {
168 :     cl <- "ddiMatrix"
169 :     uni <- all(x == 1)
170 :     storage.mode(x) <- "double"
171 :     }
172 :     new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",
173 :     x = if(uni) x[FALSE] else x)
174 :     })
175 :    
176 : maechler 1708
177 :     setMethod("diag", signature(x = "diagonalMatrix"),
178 :     function(x = 1, nrow, ncol = n) .diag.x(x))
179 :    
180 : maechler 1617 ## When you assign to a diagonalMatrix, the result should be
181 : maechler 1708 ## diagonal or sparse ---
182 :     ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch
183 : maechler 1617
184 : maechler 1710 replDiag <- function(x, i, j, value) {
185 :     x <- as(x, "sparseMatrix")
186 :     if(missing(i))
187 :     x[, j] <- value
188 :     else if(missing(j))
189 :     x[i, ] <- value
190 :     else
191 :     x[i,j] <- value
192 :     if(isDiagonal(x)) as(x, "diagonalMatrix") else x
193 :     }
194 : maechler 1617
195 : maechler 1710 setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
196 :     j = "index", value = "replValue"), replDiag)
197 :     setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
198 :     j = "missing", value = "replValue"),
199 :     function(x, i, value) replDiag(x, i=i, value=value))
200 :     setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing",
201 :     j = "index", value = "replValue"),
202 :     function(x, j, value) replDiag(x, j=j, value=value))
203 :    
204 :    
205 : maechler 1109 setMethod("t", signature(x = "diagonalMatrix"),
206 :     function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })
207 :    
208 : maechler 1331 setMethod("isDiagonal", signature(object = "diagonalMatrix"),
209 :     function(object) TRUE)
210 :     setMethod("isTriangular", signature(object = "diagonalMatrix"),
211 :     function(object) TRUE)
212 : maechler 1109 setMethod("isSymmetric", signature(object = "diagonalMatrix"),
213 :     function(object) TRUE)
214 :    
215 : maechler 1654 setMethod("chol", signature(x = "ddiMatrix"),# pivot = "ANY"
216 :     function(x, pivot) {
217 :     if(any(x@x < 0)) stop("chol() is undefined for diagonal matrix with negative entries")
218 :     x@x <- sqrt(x@x)
219 :     x
220 :     })
221 :     ## chol(L) is L for logical diagonal:
222 :     setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot) x)
223 :    
224 : maechler 1109 setMethod("!", "ldiMatrix", function(e1) {
225 :     if(e1@diag == "N")
226 :     e1@x <- !e1@x
227 :     else { ## "U"
228 :     e1@diag <- "N"
229 :     e1@x <- rep.int(FALSE, e1@Dim[1])
230 :     }
231 : maechler 1725 e1
232 : maechler 1109 })
233 :    
234 :     ## Basic Matrix Multiplication {many more to add}
235 : maechler 1654 ## ---------------------
236 :     ## Note that "ldi" logical are treated as numeric
237 : maechler 1109 diagdiagprod <- function(x, y) {
238 :     if(any(dim(x) != dim(y))) stop("non-matching dimensions")
239 :     if(x@diag != "U") {
240 : maechler 1654 if(y@diag != "U") {
241 :     nx <- x@x * y@x
242 :     if(is.numeric(nx) && !is.numeric(x@x))
243 :     x <- as(x, "dMatrix")
244 :     x@x <- as.numeric(nx)
245 :     }
246 :     return(x)
247 : maechler 1109 } else ## x is unit diagonal
248 :     return(y)
249 :     }
250 :    
251 : maechler 1654 setMethod("%*%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
252 : maechler 1109 diagdiagprod, valueClass = "ddiMatrix")
253 :    
254 : maechler 1654 formals(diagdiagprod) <- alist(x=, y=x)
255 :     setMethod("crossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
256 : maechler 1109 diagdiagprod, valueClass = "ddiMatrix")
257 : maechler 1654 setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
258 : maechler 1109 diagdiagprod, valueClass = "ddiMatrix")
259 : maechler 1654 setMethod("crossprod", signature(x = "diagonalMatrix", y = "missing"),
260 :     diagdiagprod, valueClass = "ddiMatrix")
261 :     setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "missing"),
262 :     diagdiagprod, valueClass = "ddiMatrix")
263 : maechler 1109
264 :    
265 :     diagmatprod <- function(x, y) {
266 :     dx <- dim(x)
267 :     dy <- dim(y)
268 :     if(dx[2] != dy[1]) stop("non-matching dimensions")
269 :     n <- dx[1]
270 :     as(if(x@diag == "U") y else x@x * y, "Matrix")
271 :     }
272 :    
273 :     setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"),
274 : maechler 1654 diagmatprod)
275 : maechler 1109 formals(diagmatprod) <- alist(x=, y=NULL)
276 :     setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),
277 : maechler 1654 diagmatprod)
278 :     setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "matrix"),
279 :     diagmatprod)
280 : maechler 1109
281 :     diagdgeprod <- function(x, y) {
282 :     dx <- dim(x)
283 :     dy <- dim(y)
284 :     if(dx[2] != dy[1]) stop("non-matching dimensions")
285 :     if(x@diag != "U")
286 :     y@x <- x@x * y@x
287 :     y
288 :     }
289 :     setMethod("%*%", signature(x = "diagonalMatrix", y = "dgeMatrix"),
290 :     diagdgeprod, valueClass = "dgeMatrix")
291 :     formals(diagdgeprod) <- alist(x=, y=NULL)
292 :     setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"),
293 :     diagdgeprod, valueClass = "dgeMatrix")
294 :    
295 :     setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"),
296 :     function(x, y) {
297 : maechler 1635 dx <- dim(x)
298 :     dy <- dim(y)
299 :     if(dx[2] != dy[1]) stop("non-matching dimensions")
300 :     as(if(y@diag == "U") x else x * rep(y@x, each = dx[1]), "Matrix")
301 :     })
302 : maechler 1109
303 :     setMethod("%*%", signature(x = "dgeMatrix", y = "diagonalMatrix"),
304 :     function(x, y) {
305 : maechler 1635 dx <- dim(x)
306 :     dy <- dim(y)
307 :     if(dx[2] != dy[1]) stop("non-matching dimensions")
308 :     if(y@diag == "N")
309 :     x@x <- x@x * rep(y@x, each = dx[1])
310 :     x
311 :     })
312 : maechler 1109
313 : maechler 1295 ## crossprod {more of these}
314 : maechler 1109
315 : maechler 1295 ## tcrossprod --- all are not yet there: do the dense ones here:
316 : maechler 1109
317 : maechler 1295 ## FIXME:
318 :     ## setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "denseMatrix"),
319 :     ## function(x, y = NULL) {
320 :     ## })
321 : maechler 1109
322 : maechler 1295 ## setMethod("tcrossprod", signature(x = "denseMatrix", y = "diagonalMatrix"),
323 :     ## function(x, y = NULL) {
324 :     ## })
325 : maechler 1109
326 : maechler 1295
327 : maechler 1654 ### ---------------- diagonal o sparse -----------------------------
328 : maechler 1295
329 : maechler 1655
330 :     ## Use function for several signatures, in order to evade
331 :     ## ambiguous dispatch for "ddi", since there's also Arith(ddense., ddense.)
332 :     diagOdiag <- function(e1,e2) { # result should also be diagonal
333 :     r <- callGeneric(.diag.x(e1), .diag.x(e2)) # error if not "compatible"
334 :     if(is.numeric(r)) {
335 :     if(is.numeric(e2@x)) {
336 :     e2@x <- r; return(.diag.2N(e2)) }
337 :     if(!is.numeric(e1@x))
338 :     ## e.g. e1, e2 are logical;
339 :     e1 <- as(e1, "dMatrix")
340 :     }
341 :     else if(is.logical(r))
342 :     e1 <- as(e1, "lMatrix")
343 :     else stop("intermediate 'r' is of type", typeof(r))
344 :     e1@x <- r
345 :     .diag.2N(e1)
346 :     }
347 :    
348 :     setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "diagonalMatrix"),
349 :     diagOdiag)
350 :     ## These two are just for method disambiguation:
351 :     setMethod("Ops", signature(e1 = "ddiMatrix", e2 = "diagonalMatrix"),
352 :     diagOdiag)
353 :     setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ddiMatrix"),
354 :     diagOdiag)
355 :    
356 :     ## For almost everything else, diag* shall be treated "as sparse" :
357 : maechler 1295 ## These are cheap implementations via coercion
358 :    
359 : maechler 1655 ## for disambiguation
360 : maechler 1654 setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "sparseMatrix"),
361 :     function(e1,e2) callGeneric(as(e1, "sparseMatrix"), e2))
362 :     setMethod("Ops", signature(e1 = "sparseMatrix", e2 = "diagonalMatrix"),
363 :     function(e1,e2) callGeneric(e1, as(e2, "sparseMatrix")))
364 : maechler 1655 ## in general:
365 :     setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ANY"),
366 :     function(e1,e2) callGeneric(as(e1,"sparseMatrix"), e2))
367 :     setMethod("Ops", signature(e1 = "ANY", e2 = "diagonalMatrix"),
368 :     function(e1,e2) callGeneric(e1, as(e2,"sparseMatrix")))
369 : maechler 1654
370 : maechler 1655
371 :    
372 : maechler 1295 ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
373 :     setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
374 :     function(x, y) as(x, "sparseMatrix") %*% y)
375 : maechler 1682 ## NB: The previous is *not* triggering for "ddi" o "dgC" (= distance 3)
376 :     ## since there's a "ddense" o "Csparse" at dist. 2 => triggers first.
377 :     ## ==> do this:
378 :     setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
379 :     function(x, y) as(x, "CsparseMatrix") %*% y)
380 :     ## NB: this is *not* needed for Tsparse & Rsparse
381 :     ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
382 :     ## do indeed work by going throug sparse (and *not* ddense)!
383 : maechler 1295
384 :     setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
385 :     function(x, y) x %*% as(y, "sparseMatrix"))
386 :    
387 : maechler 1748 setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),
388 :     function(a, b, ...) {
389 :     a@x <- 1/ a@x
390 :     a@Dimnames <- a@Dimnames[2:1]
391 :     a
392 :     })
393 :    
394 :     solveDiag <- function(a, b, ...) {
395 :     if((n <- a@Dim[1]) != nrow(b))
396 :     stop("incompatible matrix dimensions")
397 :     ## trivially invert a 'in place' and multiply:
398 :     a@x <- 1/ a@x
399 :     a@Dimnames <- a@Dimnames[2:1]
400 :     a %*% b
401 :     }
402 :     setMethod("solve", signature(a = "diagonalMatrix", b = "matrix"),
403 :     solveDiag)
404 :     setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),
405 :     solveDiag)
406 :    
407 :    
408 : maechler 1295 setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
409 :     function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
410 :    
411 :     setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
412 :     function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
413 :    
414 :     setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
415 :     function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
416 :    
417 :     setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
418 :     function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
419 :    
420 :    
421 : maechler 1109 ## similar to prTriang() in ./Auxiliaries.R :
422 :     prDiag <-
423 :     function(x, digits = getOption("digits"), justify = "none", right = TRUE)
424 :     {
425 :     cf <- array(".", dim = x@Dim, dimnames = x@Dimnames)
426 :     cf[row(cf) == col(cf)] <-
427 :     sapply(diag(x), format, digits = digits, justify = justify)
428 :     print(cf, quote = FALSE, right = right)
429 :     invisible(x)
430 :     }
431 :    
432 :     setMethod("show", signature(object = "diagonalMatrix"),
433 : maechler 1592 function(object) {
434 :     d <- dim(object)
435 :     cl <- class(object)
436 :     cat(sprintf('%d x %d diagonal matrix of class "%s"\n',
437 :     d[1], d[2], cl))
438 :     prDiag(object)
439 :     })

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