SCM

SCM Repository

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

Diff of /pkg/Matrix/R/ddenseMatrix.R

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

revision 2112, Mon Feb 18 08:24:46 2008 UTC revision 2115, Sat Feb 23 09:23:17 2008 UTC
# Line 31  Line 31 
31        function(from) .Call(dense_to_Csparse, from))        function(from) .Call(dense_to_Csparse, from))
32    
33  setAs("matrix", "CsparseMatrix",  setAs("matrix", "CsparseMatrix",
34        function(from) {        function(from) .Call(dense_to_Csparse, from))
35              if(is.numeric(from))  ##       function(from) {
36                  .Call(dense_to_Csparse, .Call(dup_mMatrix_as_dgeMatrix, from))  ##          if(is.numeric(from))
37              else if(is.logical(from)) ## FIXME: this works, but maybe wastefully  ##              .Call(dense_to_Csparse, .Call(dup_mMatrix_as_dgeMatrix, from))
38                  as(Matrix(from, sparse=TRUE), "CsparseMatrix")  ##          else if(is.logical(from)) ## FIXME: this works, but maybe wastefully
39              else stop('not-yet-implemented coercion to "CsparseMatrix"')  ##                 as(Matrix(from, sparse=TRUE), "CsparseMatrix")
40        })  ##          else stop('not-yet-implemented coercion to "CsparseMatrix"')
41    ##       })
42    
43    
44  ## special case needed in the Matrix function  ## special case needed in the Matrix function
# Line 119  Line 120 
120            function(x) callGeneric(as(x, "dgeMatrix")))            function(x) callGeneric(as(x, "dgeMatrix")))
121    
122    
 ### FIXME: band() et al should be extended from "ddense" to "dense" !  
 ###        However, needs much work to generalize dup_mMatrix_as_dgeMatrix()  
 ### --> use workaround below: go via "d"(ouble) and back  
123    
124  .trilDense <- function(x, k = 0, ...) {  .trilDense <- function(x, k = 0, ...) {
125      k <- as.integer(k[1])      k <- as.integer(k[1])
126      dd <- dim(x); sqr <- dd[1] == dd[2]      d <- dim(x)
127      stopifnot(-dd[1] <= k, k <= dd[1]) # had k <= 0      stopifnot(-d[1] <= k, k <= d[1]) # had k <= 0
128      ## returns "lower triangular" if k <= 0 && sqr      ## returns "lower triangular" if k <= 0 && sqr
129      .Call(ddense_band, x, -dd[1], k)      .Call(dense_band, x, -d[1], k)
130  }  }
131  ## NB: have extra tril(), triu() methods for symmetric ["dsy" and "dsp"] and  ## NB: have extra tril(), triu() methods for symmetric ["dsy" and "dsp"] and
132  ##     for triangular ["dtr" and "dtp"]  ##     for triangular ["dtr" and "dtp"]
133  setMethod("tril", "ddenseMatrix", .trilDense)  setMethod("tril", "denseMatrix", .trilDense)
134  setMethod("tril",       "matrix",  setMethod("tril",      "matrix", .trilDense)
           function(x, k = 0, ...) {  
               if(is.double(x)) .trilDense(x, k)  
               else {  
                   r <- .trilDense(x, k)  
                   storage.mode(r) <- storage.mode(x)  
                   r  
               }})  
 setMethod("tril", "denseMatrix",# all but ddense*  
           function(x, k = 0, ...)  
               as(.trilDense(as(x, "dMatrix"), k), class(x)))  
135    
136  .triuDense <- function(x, k = 0, ...) {  .triuDense <- function(x, k = 0, ...) {
137      k <- as.integer(k[1])      k <- as.integer(k[1])
138      dd <- dim(x); sqr <- dd[1] == dd[2]      d <- dim(x)
139      stopifnot(-dd[1] <= k, k <= dd[1]) # had k >= 0      stopifnot(-d[1] <= k, k <= d[1]) # had k >= 0
140      ## returns "upper triangular" if k >= 0      ## returns "upper triangular" if k >= 0
141      .Call(ddense_band, x, k, dd[2])      .Call(dense_band, x, k, d[2])
142  }  }
143  setMethod("triu", "ddenseMatrix", .triuDense)  setMethod("triu", "denseMatrix", .triuDense)
144  setMethod("triu",       "matrix",  setMethod("triu",      "matrix", .triuDense)
           function(x, k = 0, ...) {  
               if(is.double(x)) .triuDense(x, k)  
               else {  
                   r <- .triuDense(x, k)  
                   storage.mode(r) <- storage.mode(x)  
                   r  
               }})  
 setMethod("triu", "denseMatrix",# all but ddense*  
           function(x, k = 0, ...)  
               as(.triuDense(as(x, "dMatrix"), k), class(x)))  
145    
146  .bandDense <- function(x, k1, k2, ...) {  .bandDense <- function(x, k1, k2, ...) {
147      k1 <- as.integer(k1[1])      k1 <- as.integer(k1[1])
148      k2 <- as.integer(k2[1])      k2 <- as.integer(k2[1])
149      dd <- dim(x); sqr <- dd[1] == dd[2]      dd <- dim(x); sqr <- dd[1] == dd[2]
150      stopifnot(-dd[1] <= k1, k1 <= k2, k2 <= dd[1])      stopifnot(-dd[1] <= k1, k1 <= k2, k2 <= dd[1])
151      r <- .Call(ddense_band, x, k1, k2)      r <- .Call(dense_band, x, k1, k2)
152      if (k1 < 0  &&  k1 == -k2  && isSymmetric(x)) ## symmetric      if (sqr &&  k1 < 0 &&  k1 == -k2  && isSymmetric(x)) ## symmetric
153          as(r, paste(.M.kind(x), "syMatrix", sep=''))          forceSymmetric(r)
154      else      else
155          r          r
156  }  }
157    setMethod("band", "denseMatrix", .bandDense)
158    setMethod("band",      "matrix", .bandDense)
159    
 setMethod("band", "ddenseMatrix", .bandDense)  
 setMethod("band",       "matrix",  
           function(x, k1, k2, ...) {  
               if(is.double(x)) .bandDense(x, k1, k2)  
               else {  
                   r <- .bandDense(x, k1, k2)  
                   storage.mode(r) <- storage.mode(x)  
                   r  
               }})  
 setMethod("band", "denseMatrix",# all but ddense*  
           function(x, k1, k2, ...)  
               as(.bandDense(as(x, "dMatrix"), k1, k2), class(x)))  
160    
161  setMethod("symmpart", signature(x = "ddenseMatrix"),  setMethod("symmpart", signature(x = "ddenseMatrix"),
162            function(x) .Call(ddense_symmpart, x))            function(x) .Call(ddense_symmpart, x))

Legend:
Removed from v.2112  
changed lines
  Added in v.2115

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