SCM

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1725, Wed Jan 17 08:01:10 2007 UTC revision 1805, Tue Mar 27 16:46:03 2007 UTC
# Line 68  Line 68 
68    
69  setAs("diagonalMatrix", "triangularMatrix", diag2T)  setAs("diagonalMatrix", "triangularMatrix", diag2T)
70  setAs("diagonalMatrix", "sparseMatrix", diag2T)  setAs("diagonalMatrix", "sparseMatrix", diag2T)
71    ## needed too (otherwise <dense> -> Tsparse is taken):
72    setAs("diagonalMatrix", "TsparseMatrix", diag2T)
73  ## is better than this:  ## is better than this:
74  ## setAs("diagonalMatrix", "sparseMatrix",  ## setAs("diagonalMatrix", "sparseMatrix",
75  ##       function(from)  ##       function(from)
# Line 177  Line 179 
179  setMethod("diag", signature(x = "diagonalMatrix"),  setMethod("diag", signature(x = "diagonalMatrix"),
180            function(x = 1, nrow, ncol = n) .diag.x(x))            function(x = 1, nrow, ncol = n) .diag.x(x))
181    
182    
183    subDiag <- function(x, i, j, drop) {
184        x <- as(x, "sparseMatrix")
185        x <- if(missing(i))
186            x[, j, drop=drop]
187        else if(missing(j))
188            x[i, , drop=drop]
189        else
190            x[i,j, drop=drop]
191        if(isDiagonal(x)) as(x, "diagonalMatrix") else x
192    }
193    
194    setMethod("[", signature(x = "diagonalMatrix", i = "index",
195                             j = "index", drop = "logical"), subDiag)
196    setMethod("[", signature(x = "diagonalMatrix", i = "index",
197                            j = "missing", drop = "logical"),
198              function(x, i, drop) subDiag(x, i=i, drop=drop))
199    setMethod("[", signature(x = "diagonalMatrix", i = "missing",
200                             j = "index", drop = "logical"),
201              function(x, j, drop) subDiag(x, j=j, drop=drop))
202    
203  ## When you assign to a diagonalMatrix, the result should be  ## When you assign to a diagonalMatrix, the result should be
204  ## diagonal or sparse ---  ## diagonal or sparse ---
205  ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch  ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch
   
206  replDiag <- function(x, i, j, value) {  replDiag <- function(x, i, j, value) {
207      x <- as(x, "sparseMatrix")      x <- as(x, "sparseMatrix")
208      if(missing(i))      if(missing(i))
# Line 323  Line 345 
345  ##        function(x, y = NULL) {  ##        function(x, y = NULL) {
346  ##           })  ##           })
347    
348    setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
349              function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
350    
351    setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
352              function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
353    
354    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
355              function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
356    
357    setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
358              function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
359    
360    
361    ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
362    setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
363              function(x, y) as(x, "sparseMatrix") %*% y)
364    ## NB: The previous is *not* triggering for  "ddi" o "dgC" (= distance 3)
365    ##     since there's a "ddense" o "Csparse" at dist. 2 => triggers first.
366    ## ==> do this:
367    setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
368              function(x, y) as(x, "CsparseMatrix") %*% y)
369    setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
370              function(x, y) x %*% as(y, "CsparseMatrix"))
371    ## NB: this is *not* needed for Tsparse & Rsparse
372    ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
373    ##       do indeed work by going through sparse (and *not* ddense)!
374    
375    setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
376              function(x, y) x %*% as(y, "sparseMatrix"))
377    
378    
379    setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),
380              function(a, b, ...) {
381                  a@x <- 1/ a@x
382                  a@Dimnames <- a@Dimnames[2:1]
383                  a
384              })
385    
386    solveDiag <- function(a, b, ...) {
387        if((n <- a@Dim[1]) != nrow(b))
388            stop("incompatible matrix dimensions")
389        ## trivially invert a 'in place' and multiply:
390        a@x <- 1/ a@x
391        a@Dimnames <- a@Dimnames[2:1]
392        a %*% b
393    }
394    setMethod("solve", signature(a = "diagonalMatrix", b = "matrix"),
395              solveDiag)
396    setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),
397              solveDiag)
398    
399    
400    
401    
402  ### ---------------- diagonal  o  sparse  -----------------------------  ### ---------------- diagonal  o  sparse  -----------------------------
403    
# Line 369  Line 444 
444    
445    
446    
 ## 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("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() })  
   
   
447  ## similar to prTriang() in ./Auxiliaries.R :  ## similar to prTriang() in ./Auxiliaries.R :
448  prDiag <-  prDiag <-
449      function(x, digits = getOption("digits"), justify = "none", right = TRUE)      function(x, digits = getOption("digits"), justify = "none", right = TRUE)

Legend:
Removed from v.1725  
changed lines
  Added in v.1805

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