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 1798, Sat Mar 24 14:52:47 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.1798  
changed lines
  Added in v.1799

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