# SCM Repository

[matrix] Diff of /pkg/R/diagMatrix.R
 [matrix] / pkg / R / diagMatrix.R

# Diff of /pkg/R/diagMatrix.R

revision 1655, Mon Oct 30 17:16:27 2006 UTC revision 1748, Mon Jan 29 20:48:26 2007 UTC
# Line 173  Line 173
173                x = if(uni) x[FALSE] else x)                x = if(uni) x[FALSE] else x)
174        })        })
175
176
177    setMethod("diag", signature(x = "diagonalMatrix"),
178              function(x = 1, nrow, ncol = n) .diag.x(x))
179
180  ## When you assign to a diagonalMatrix, the result should be  ## When you assign to a diagonalMatrix, the result should be
181  ## diagonal or sparse  ## diagonal or sparse ---
182  setReplaceMethod("[", signature(x = "diagonalMatrix",  ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch
183                                  i = "ANY", j = "ANY", value = "ANY"),
184                   function(x, i, j, value) {  replDiag <- function(x, i, j, value) {
185                       r <- callGeneric(x = as(x,"sparseMatrix"),      x <- as(x, "sparseMatrix")
186                                        i=i, j=j, value=value)      if(missing(i))
187                       if(isDiagonal(r)) as(r, "diagonalMatrix") else r          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
195    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  setMethod("t", signature(x = "diagonalMatrix"),  setMethod("t", signature(x = "diagonalMatrix"),
# Line 203  Line 221
221  ## chol(L) is L for logical diagonal:  ## chol(L) is L for logical diagonal:
222  setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot) x)  setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot) x)
223

setMethod("diag", signature(x = "diagonalMatrix"),
function(x = 1, nrow, ncol = n) {
if(x@diag == "U")
rep.int(if(is.logical(x@x)) TRUE else 1, x@Dim[1])
else x@x
})

224  setMethod("!", "ldiMatrix", function(e1) {  setMethod("!", "ldiMatrix", function(e1) {
225      if(e1@diag == "N")      if(e1@diag == "N")
226          e1@x <- !e1@x          e1@x <- !e1@x
# Line 218  Line 228
228          e1@diag <- "N"          e1@diag <- "N"
229          e1@x <- rep.int(FALSE, e1@Dim[1])          e1@x <- rep.int(FALSE, e1@Dim[1])
230      }      }
231      x      e1
232  })  })
233
234  ## Basic Matrix Multiplication {many more to add}  ## Basic Matrix Multiplication {many more to add}
# Line 360  Line 370
370
371
372  ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()  ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()

373  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
374            function(x, y) as(x, "sparseMatrix") %*% y)            function(x, y) as(x, "sparseMatrix") %*% y)
375    ## 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
384  setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),  setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
385            function(x, y) x %*% as(y, "sparseMatrix"))            function(x, y) x %*% as(y, "sparseMatrix"))
386
387    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  setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
409            function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })            function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
410
# Line 380  Line 418
418            function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })            function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
419
420

421  ## similar to prTriang() in ./Auxiliaries.R :  ## similar to prTriang() in ./Auxiliaries.R :
422  prDiag <-  prDiag <-
423      function(x, digits = getOption("digits"), justify = "none", right = TRUE)      function(x, digits = getOption("digits"), justify = "none", right = TRUE)

Legend:
 Removed from v.1655 changed lines Added in v.1748