# SCM Repository

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

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

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: