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 2123, Wed Mar 5 08:44:52 2008 UTC revision 2128, Thu Mar 13 23:08:34 2008 UTC
# Line 16  Line 16 
16      if(missing(x)) ## unit diagonal matrix      if(missing(x)) ## unit diagonal matrix
17          new("ddiMatrix", Dim = c(n,n), diag = "U")          new("ddiMatrix", Dim = c(n,n), diag = "U")
18      else {      else {
19          stopifnot(length(x) == n)          lx <- length(x)
20            stopifnot(lx == 1 || lx == n) # but keep 'x' short for now
21          if(is.logical(x))          if(is.logical(x))
22              cl <- "ldiMatrix"              cl <- "ldiMatrix"
23          else if(is.numeric(x)) {          else if(is.numeric(x)) {
# Line 26  Line 27 
27          else if(is.complex(x)) {          else if(is.complex(x)) {
28              cl <- "zdiMatrix"  # will not yet work              cl <- "zdiMatrix"  # will not yet work
29          } else stop("'x' has invalid data type")          } else stop("'x' has invalid data type")
30          new(cl, Dim = c(n,n), diag = "N", x = x)          new(cl, Dim = c(n,n), diag = "N",
31                x = if(lx == 1) rep.int(x,n) else x)
32      }      }
33  }  }
34    
# Line 58  Line 60 
60      as(ret, "CsparseMatrix")      as(ret, "CsparseMatrix")
61  }  }
62    
63  diag2tT <- function(from) {  
64    .diag2tT <- function(from, uplo = "U") { ## to triangular Tsparse
65      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
66      new(paste(.M.kind(from), "tTMatrix", sep=''),      new(paste(.M.kind(from), "tTMatrix", sep=''),
67          diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,          diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,
68            uplo = uplo,
69          x = from@x, # <- ok for diag = "U" and "N" (!)          x = from@x, # <- ok for diag = "U" and "N" (!)
70          i = i, j = i)          i = i, j = i)
71  }  }
72    
73  diag2sT <- function(from) { # to symmetric Tsparse  diag2tT <- function(from) .diag2tT(from, "U")
74      i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L  
75      new(paste(.M.kind(from), "sTMatrix", sep=''),  .diag2sT <- function(from, uplo = "U") { # to symmetric Tsparse
76        n <- from@Dim[1]
77        i <- seq_len(n) - 1L
78        kind <- .M.kind(from)
79        new(paste(kind, "sTMatrix", sep=''),
80          Dim = from@Dim, Dimnames = from@Dimnames,          Dim = from@Dim, Dimnames = from@Dimnames,
81          x = from@x, i = i, j = i)          i = i, j = i, uplo = uplo,
82            x = if(from@diag == "N") from@x else ## "U"-diag
83            rep.int(switch(kind,
84                           "d" = 1.,
85                           "l" =,
86                           "n" = TRUE,
87                           ## otherwise
88                           stop("'", kind,"' kind not yet implemented")), n))
89  }  }
90    
91    diag2sT <- function(from) .diag2sT(from, "U")
92    
93    ## diagonal -> triangular,  upper / lower depending on "partner":
94    diag2tT.u <- function(d, x)
95        .diag2tT(d, uplo = if(is(x,"triangularMatrix")) x@uplo else "U")
96    
97  setAs("diagonalMatrix", "triangularMatrix", diag2tT)  setAs("diagonalMatrix", "triangularMatrix", diag2tT)
98  setAs("diagonalMatrix", "sparseMatrix", diag2tT)  setAs("diagonalMatrix", "sparseMatrix", diag2tT)
99  ## needed too (otherwise <dense> -> Tsparse is taken):  ## needed too (otherwise <dense> -> Tsparse is taken):
# Line 86  Line 107 
107    
108  setAs("diagonalMatrix", "symmetricMatrix", diag2sT)  setAs("diagonalMatrix", "symmetricMatrix", diag2sT)
109    
110    setAs("diagonalMatrix", "nMatrix",
111          function(from) {
112              n <- from@Dim[1]
113              i <- if(from@diag == "U") integer(0) else which(isN0(from@x)) - 1L
114              new("ntTMatrix", i = i, j = i, diag = from@diag,
115                  Dim = from@Dim, Dimnames = from@Dimnames)
116          })
117    
118    
119  setAs("diagonalMatrix", "matrix",  setAs("diagonalMatrix", "matrix",
120        function(from) {        function(from) {
121            n <- from@Dim[1]            n <- from@Dim[1]
# Line 109  Line 139 
139            })            })
140    
141  setAs("diagonalMatrix", "generalMatrix", # prefer sparse:  setAs("diagonalMatrix", "generalMatrix", # prefer sparse:
142        function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))        function(from) as(as(from, "CsparseMatrix"), "generalMatrix"))
143    
144  .diag.x <- function(m) {  .diag.x <- function(m) {
145      if(m@diag == "U")      if(m@diag == "U")
# Line 123  Line 153 
153      m      m
154  }  }
155    
156    if(FALSE) {
157  ## given the above, the following  4  coercions should be all unneeded;  ## given the above, the following  4  coercions should be all unneeded;
158  ## we prefer triangular to general:  ## we prefer triangular to general:
159  setAs("ddiMatrix", "dgTMatrix",  setAs("ddiMatrix", "dgTMatrix",
# Line 153  Line 184 
184    
185  setAs("ldiMatrix", "lgCMatrix",  setAs("ldiMatrix", "lgCMatrix",
186        function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))        function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))
187    }
188    
189    
190  if(FALSE) # now have faster  "ddense" -> "dge"  if(FALSE) # now have faster  "ddense" -> "dge"
# Line 488  Line 520 
520  ## For almost everything else, diag* shall be treated "as sparse" :  ## For almost everything else, diag* shall be treated "as sparse" :
521  ## These are cheap implementations via coercion  ## These are cheap implementations via coercion
522    
523  ## for disambiguation  ## for disambiguation --- define this for "sparseMatrix" , then for "ANY" :
524  setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "sparseMatrix"),  setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "sparseMatrix"),
525            function(e1,e2) callGeneric(as(e1, "sparseMatrix"), e2))            function(e1,e2) callGeneric(diag2tT.u(e1,e2), e2))
526  setMethod("Ops", signature(e1 = "sparseMatrix", e2 = "diagonalMatrix"),  setMethod("Ops", signature(e1 = "sparseMatrix", e2 = "diagonalMatrix"),
527            function(e1,e2) callGeneric(e1, as(e2, "sparseMatrix")))            function(e1,e2) callGeneric(e1, diag2tT.u(e2,e1)))
528  ## in general:  ## in general:
529  setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ANY"),  setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ANY"),
530            function(e1,e2) callGeneric(as(e1,"sparseMatrix"), e2))            function(e1,e2) callGeneric(diag2tT.u(e1,e2), e2))
531  setMethod("Ops", signature(e1 = "ANY", e2 = "diagonalMatrix"),  setMethod("Ops", signature(e1 = "ANY", e2 = "diagonalMatrix"),
532            function(e1,e2) callGeneric(e1, as(e2,"sparseMatrix")))            function(e1,e2) callGeneric(e1, diag2tT.u(e2,e1)))
533    
534    
535    

Legend:
Removed from v.2123  
changed lines
  Added in v.2128

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