# SCM Repository

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

# Diff of /pkg/Matrix/R/diagMatrix.R

revision 1748, Mon Jan 29 20:48:26 2007 UTC revision 1799, Sat Mar 24 14:54:00 2007 UTC
# Line 177  Line 177
177  setMethod("diag", signature(x = "diagonalMatrix"),  setMethod("diag", signature(x = "diagonalMatrix"),
178            function(x = 1, nrow, ncol = n) .diag.x(x))            function(x = 1, nrow, ncol = n) .diag.x(x))
179
180
181    subDiag <- function(x, i, j, drop) {
182        x <- as(x, "sparseMatrix")
183        x <- if(missing(i))
184            x[, j, drop=drop]
185        else if(missing(j))
186            x[i, , drop=drop]
187        else
188            x[i,j, drop=drop]
189        if(isDiagonal(x)) as(x, "diagonalMatrix") else x
190    }
191
192    setMethod("[", signature(x = "diagonalMatrix", i = "index",
193                             j = "index", drop = "logical"), subDiag)
194    setMethod("[", signature(x = "diagonalMatrix", i = "index",
195                            j = "missing", drop = "logical"),
196              function(x, i, drop) subDiag(x, i=i, drop=drop))
197    setMethod("[", signature(x = "diagonalMatrix", i = "missing",
198                             j = "index", drop = "logical"),
199              function(x, j, drop) subDiag(x, j=j, drop=drop))
200
201  ## When you assign to a diagonalMatrix, the result should be  ## When you assign to a diagonalMatrix, the result should be
202  ## diagonal or sparse ---  ## diagonal or sparse ---
203  ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch  ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch

204  replDiag <- function(x, i, j, value) {  replDiag <- function(x, i, j, value) {
205      x <- as(x, "sparseMatrix")      x <- as(x, "sparseMatrix")
206      if(missing(i))      if(missing(i))
# Line 323  Line 343
343  ##        function(x, y = NULL) {  ##        function(x, y = NULL) {
344  ##           })  ##           })
345
346    setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
347              function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
348
349    setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
350              function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
351
352    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
353              function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
354
355    setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
356              function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
357
358
359    ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
360    setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
361              function(x, y) as(x, "sparseMatrix") %*% y)
362    ## NB: The previous is *not* triggering for  "ddi" o "dgC" (= distance 3)
363    ##     since there's a "ddense" o "Csparse" at dist. 2 => triggers first.
364    ## ==> do this:
365    setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
366              function(x, y) as(x, "CsparseMatrix") %*% y)
367    setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
368              function(x, y) x %*% as(y, "CsparseMatrix"))
369    ## NB: this is *not* needed for Tsparse & Rsparse
370    ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
371    ##       do indeed work by going through sparse (and *not* ddense)!
372
373    setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
374              function(x, y) x %*% as(y, "sparseMatrix"))
375
376
377    setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),
378              function(a, b, ...) {
379                  a@x <- 1/ a@x
380                  a@Dimnames <- a@Dimnames[2:1]
381                  a
382              })
383
384    solveDiag <- function(a, b, ...) {
385        if((n <- a@Dim[1]) != nrow(b))
386            stop("incompatible matrix dimensions")
387        ## trivially invert a 'in place' and multiply:
388        a@x <- 1/ a@x
389        a@Dimnames <- a@Dimnames[2:1]
390        a %*% b
391    }
392    setMethod("solve", signature(a = "diagonalMatrix", b = "matrix"),
393              solveDiag)
394    setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),
395              solveDiag)
396
397
398
399
400  ### ---------------- diagonal  o  sparse  -----------------------------  ### ---------------- diagonal  o  sparse  -----------------------------
401
# Line 369  Line 442
442
443
444
## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
function(x, y) as(x, "sparseMatrix") %*% y)
## NB: The previous is *not* triggering for  "ddi" o "dgC" (= distance 3)
##     since there's a "ddense" o "Csparse" at dist. 2 => triggers first.
## ==> do this:
setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
function(x, y) as(x, "CsparseMatrix") %*% y)
## NB: this is *not* needed for Tsparse & Rsparse
## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
##       do indeed work by going throug sparse (and *not* ddense)!

setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
function(x, y) x %*% as(y, "sparseMatrix"))

setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),
function(a, b, ...) {
a@x <- 1/ a@x
a@Dimnames <- a@Dimnames[2:1]
a
})

solveDiag <- function(a, b, ...) {
if((n <- a@Dim[1]) != nrow(b))
stop("incompatible matrix dimensions")
## trivially invert a 'in place' and multiply:
a@x <- 1/ a@x
a@Dimnames <- a@Dimnames[2:1]
a %*% b
}
setMethod("solve", signature(a = "diagonalMatrix", b = "matrix"),
solveDiag)
setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),
solveDiag)

setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })

setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })

setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })

setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })

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

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