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 2133, Sat Mar 15 18:56:50 2008 UTC revision 2136, Mon Mar 17 22:20:29 2008 UTC
# Line 61  Line 61 
61  }  }
62    
63    
64  .diag2tT <- function(from, uplo = "U") { ## to triangular Tsparse  .diag2tT <- function(from, uplo = "U", kind = .M.kind(from)) {
65        ## to triangular Tsparse
66      i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L      i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L
67      new(paste(.M.kind(from), "tTMatrix", sep=''),      new(paste(kind, "tTMatrix", sep=''),
68          diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,          diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,
69          uplo = uplo,          uplo = uplo,
70          x = from@x, # <- ok for diag = "U" and "N" (!)          x = from@x, # <- ok for diag = "U" and "N" (!)
71          i = i, j = i)          i = i, j = i)
72  }  }
73    
74  diag2tT <- function(from) .diag2tT(from, "U")  .diag2sT <- function(from, uplo = "U", kind = .M.kind(from)) {
75        ## to symmetric Tsparse
 .diag2sT <- function(from, uplo = "U") { # to symmetric Tsparse  
76      n <- from@Dim[1]      n <- from@Dim[1]
77      i <- seq_len(n) - 1L      i <- seq_len(n) - 1L
     kind <- .M.kind(from)  
78      new(paste(kind, "sTMatrix", sep=''),      new(paste(kind, "sTMatrix", sep=''),
79          Dim = from@Dim, Dimnames = from@Dimnames,          Dim = from@Dim, Dimnames = from@Dimnames,
80          i = i, j = i, uplo = uplo,          i = i, j = i, uplo = uplo,
# Line 88  Line 87 
87                         stop("'", kind,"' kind not yet implemented")), n))                         stop("'", kind,"' kind not yet implemented")), n))
88  }  }
89    
 diag2sT <- function(from) .diag2sT(from, "U")  
   
90  ## diagonal -> triangular,  upper / lower depending on "partner":  ## diagonal -> triangular,  upper / lower depending on "partner":
91  diag2tT.u <- function(d, x)  diag2tT.u <- function(d, x)
92      .diag2tT(d, uplo = if(is(x,"triangularMatrix")) x@uplo else "U")      .diag2tT(d, uplo = if(is(x,"triangularMatrix")) x@uplo else "U")
93    
94  setAs("diagonalMatrix", "triangularMatrix", diag2tT)  
95  setAs("diagonalMatrix", "sparseMatrix", diag2tT)  ## In order to evade method dispatch ambiguity warnings,
96    ## and because we can save a .M.kind() call, we use this explicit
97    ## "hack"  instead of signature  x = "diagonalMatrix" :
98    ##
99    ## ddi*:
100    diag2tT <- function(from) .diag2tT(from, "U", "d")
101    setAs("ddiMatrix", "triangularMatrix", diag2tT)
102    setAs("ddiMatrix", "sparseMatrix", diag2tT)
103  ## needed too (otherwise <dense> -> Tsparse is taken):  ## needed too (otherwise <dense> -> Tsparse is taken):
104  setAs("diagonalMatrix", "TsparseMatrix", diag2tT)  setAs("ddiMatrix", "TsparseMatrix", diag2tT)
105  ## is better than this:  setAs("ddiMatrix", "CsparseMatrix",
106  ## setAs("diagonalMatrix", "sparseMatrix",        function(from) as(.diag2tT(from, "U", "d"), "CsparseMatrix"))
107  ##       function(from)  setAs("ddiMatrix", "symmetricMatrix",
108  ##        as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))        function(from) .diag2sT(from, "U", "d"))
109  setAs("diagonalMatrix", "CsparseMatrix",  ##
110        function(from) as(diag2tT(from), "CsparseMatrix"))  ## ldi*:
111    diag2tT <- function(from) .diag2tT(from, "U", "l")
112    setAs("ldiMatrix", "triangularMatrix", diag2tT)
113    setAs("ldiMatrix", "sparseMatrix", diag2tT)
114    ## needed too (otherwise <dense> -> Tsparse is taken):
115    setAs("ldiMatrix", "TsparseMatrix", diag2tT)
116    setAs("ldiMatrix", "CsparseMatrix",
117          function(from) as(.diag2tT(from, "U", "l"), "CsparseMatrix"))
118    setAs("ldiMatrix", "symmetricMatrix",
119          function(from) .diag2sT(from, "U", "l"))
120    
 setAs("diagonalMatrix", "symmetricMatrix", diag2sT)  
121    
122  setAs("diagonalMatrix", "nMatrix",  setAs("diagonalMatrix", "nMatrix",
123        function(from) {        function(from) {
# Line 143  Line 155 
155    
156  .diag.x <- function(m) {  .diag.x <- function(m) {
157      if(m@diag == "U")      if(m@diag == "U")
158          rep.int(if(is.numeric(m@x)) 1. else TRUE,          rep.int(if(is.numeric(m@x)) 1. else TRUE, m@Dim[1])
                 m@Dim[1])  
159      else m@x      else m@x
160  }  }
161    
# Line 231  Line 242 
242        })        })
243    
244    
245  setMethod("diag", signature(x = "diagonalMatrix"),  ## In order to evade method dispatch ambiguity warnings,
246    ## we use this hack instead of signature  x = "diagonalMatrix" :
247    diCls <- names(getClass("diagonalMatrix")@subclasses)
248    for(cls in diCls) {
249        setMethod("diag", signature(x = cls),
250            function(x = 1, nrow, ncol) .diag.x(x))            function(x = 1, nrow, ncol) .diag.x(x))
251    }
252    
253    
254  subDiag <- function(x, i, j, ..., drop) {  subDiag <- function(x, i, j, ..., drop) {

Legend:
Removed from v.2133  
changed lines
  Added in v.2136

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