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

pkg/R/ddenseMatrix.R revision 2052, Wed Aug 15 13:33:19 2007 UTC pkg/Matrix/R/ddenseMatrix.R revision 3018, Sat Oct 11 17:52:10 2014 UTC
# Line 5  Line 5 
5  ##   -----  in  ../src/Mutils.c  ##   -----  in  ../src/Mutils.c
6    
7  setAs("ddenseMatrix", "dgeMatrix",  setAs("ddenseMatrix", "dgeMatrix",
8        function(from) {        function(from) .Call(dup_mMatrix_as_dgeMatrix, from))
9            if (class(from) != "dgeMatrix")  
10                .Call(dup_mMatrix_as_dgeMatrix, from)  setAs("ddenseMatrix", "matrix",
11            else from        function(from) as(as(from, "dgeMatrix"), "matrix"))
       })  
12    
13  ## d(ouble) to l(ogical):  ## d(ouble) to l(ogical):
14  setAs("dgeMatrix", "lgeMatrix", function(from) d2l_Matrix(from, "dgeMatrix"))  setAs("dgeMatrix", "lgeMatrix", function(from) d2l_Matrix(from, "dgeMatrix"))
# Line 18  Line 17 
17  setAs("dtrMatrix", "ltrMatrix", function(from) d2l_Matrix(from, "dtrMatrix"))  setAs("dtrMatrix", "ltrMatrix", function(from) d2l_Matrix(from, "dtrMatrix"))
18  setAs("dtpMatrix", "ltpMatrix", function(from) d2l_Matrix(from, "dtpMatrix"))  setAs("dtpMatrix", "ltpMatrix", function(from) d2l_Matrix(from, "dtpMatrix"))
19    
20    if(FALSE) ## FIXME, this fails for ("dtpMatrix" -> "CsparseMatrix") where .dense2C() works
21  setAs("ddenseMatrix", "CsparseMatrix",  setAs("ddenseMatrix", "CsparseMatrix",
22        function(from) {        function(from) {
23            if (class(from) != "dgeMatrix") # don't lose symmetry/triangularity/...            if (class(from) != "dgeMatrix") # don't lose symmetry/triangularity/...
# Line 30  Line 30 
30        function(from) .Call(dense_to_Csparse, from))        function(from) .Call(dense_to_Csparse, from))
31    
32  setAs("matrix", "CsparseMatrix",  setAs("matrix", "CsparseMatrix",
33        function(from) {        function(from) .Call(dense_to_Csparse, from))
             if(is.numeric(from))  
                 .Call(dense_to_Csparse, .Call(dup_mMatrix_as_dgeMatrix, from))  
             else if(is.logical(from)) ## FIXME: this works, but maybe wastefully  
                 as(Matrix(from, sparse=TRUE), "CsparseMatrix")  
             else stop('not-yet-implemented coercion to "CsparseMatrix"')  
       })  
   
34    
35  ## special case needed in the Matrix function  ## for historical i.e. backcompatibility reasons ..
36  setAs("matrix", "dgCMatrix",  setAs("matrix", "dgCMatrix",
37        function(from) {        function(from) {
38            storage.mode(from) <- "double"            storage.mode(from) <- "double"
# Line 60  Line 53 
53  ## dgeMatrix. Methods for special forms override these.  ## dgeMatrix. Methods for special forms override these.
54    
55  setMethod("norm", signature(x = "ddenseMatrix", type = "missing"),  setMethod("norm", signature(x = "ddenseMatrix", type = "missing"),
56            function(x, type, ...) callGeneric(as(x, "dgeMatrix")))            function(x, type, ...) norm(as(x, "dgeMatrix")))
57    
58  setMethod("norm", signature(x = "ddenseMatrix", type = "character"),  setMethod("norm", signature(x = "ddenseMatrix", type = "character"),
59            function(x, type, ...) callGeneric(as(x, "dgeMatrix"), type))            function(x, type, ...) norm(as(x, "dgeMatrix"), type))
60    
61  setMethod("rcond", signature(x = "ddenseMatrix", type = "missing"),  setMethod("rcond", signature(x = "ddenseMatrix", norm = "missing"),
62            function(x, type, ...) callGeneric(as(x, "dgeMatrix")))            function(x, norm, ...) rcond(as(x, "dgeMatrix"), ...))
63    
64  setMethod("rcond", signature(x = "ddenseMatrix", type = "character"),  setMethod("rcond", signature(x = "ddenseMatrix", norm = "character"),
65            function(x, type, ...) callGeneric(as(x, "dgeMatrix"), type))            function(x, norm, ...) rcond(as(x, "dgeMatrix"), norm, ...))
66    
67  ## Not really useful; now require *identical* class for result:  ## Not really useful; now require *identical* class for result:
68  ## setMethod("t", signature(x = "ddenseMatrix"),  ## setMethod("t", signature(x = "ddenseMatrix"),
69  ##        function(x) callGeneric(as(x, "dgeMatrix")))  ##        function(x) callGeneric(as(x, "dgeMatrix")))
70    
71  setMethod("tcrossprod", signature(x = "ddenseMatrix", y = "missing"),  ## "diag" --> specific methods for dge, dtr,dtp, dsy,dsp
           function(x, y = NULL) callGeneric(as(x, "dgeMatrix")))  
   
 setMethod("crossprod", signature(x = "ddenseMatrix", y = "missing"),  
           function(x, y = NULL) callGeneric(as(x, "dgeMatrix")))  
   
 setMethod("diag", signature(x = "ddenseMatrix"),  
           function(x, nrow, ncol) callGeneric(as(x, "dgeMatrix")))  
72    
73  setMethod("solve", signature(a = "ddenseMatrix", b = "missing"),  setMethod("solve", signature(a = "ddenseMatrix", b = "missing"),
74            function(a, b, ...) callGeneric(as(a, "dgeMatrix")))            function(a, b, ...) solve(as(a, "dgeMatrix")))
75    
76  setMethod("solve", signature(a = "ddenseMatrix", b = "ANY"),  for(.b in c("Matrix","ANY")) ## << against ambiguity notes
77            function(a, b, ...) callGeneric(as(a, "dgeMatrix"), b))  setMethod("solve", signature(a = "ddenseMatrix", b = .b),
78              function(a, b, ...) solve(as(a, "dgeMatrix"), b))
79  ## General method for dense matrix multiplication in case specific methods  for(.b in c("matrix","numeric")) ## << against ambiguity notes
80  ## have not been defined.  setMethod("solve", signature(a = "ddenseMatrix", b = .b),
81  setMethod("%*%", signature(x = "ddenseMatrix", y = "ddenseMatrix"),            function(a, b, ...) solve(as(a, "dgeMatrix"), Matrix(b)))
82            function(x, y) .Call(dgeMatrix_matrix_mm,  rm(.b)
                                .Call(dup_mMatrix_as_dgeMatrix, x), y, FALSE),  
           valueClass = "dgeMatrix")  
83    
84  setMethod("lu", signature(x = "ddenseMatrix"),  setMethod("lu", signature(x = "ddenseMatrix"),
85            function(x, ...) callGeneric(as(x, "dgeMatrix")))            function(x, ...)
86              .set.factors(x, "LU", lu(as(x, "dgeMatrix"), ...)))
87    
88  setMethod("chol", signature(x = "ddenseMatrix", pivot = "ANY"), cholMat)  setMethod("chol", signature(x = "ddenseMatrix"), cholMat)
89    
90  setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "missing"),  setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "missing"),
91            function(x, logarithm, ...) callGeneric(as(x, "dgeMatrix")))            function(x, logarithm, ...) determinant(as(x, "dgeMatrix")))
92    
93  setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "logical"),  setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "logical"),
94            function(x, logarithm, ...)            function(x, logarithm, ...)
95            callGeneric(as(x, "dgeMatrix"), logarithm))            determinant(as(x, "dgeMatrix"), logarithm))
96    
97  ## now done for "dMatrix":  ## now done for "dMatrix":
98  ## setMethod("expm", signature(x = "ddenseMatrix"),  ## setMethod("expm", signature(x = "ddenseMatrix"),
99  ##           function(x) callGeneric(as(x, "dgeMatrix")))  ##           function(x) callGeneric(as(x, "dgeMatrix")))
100    
 setMethod("Schur", signature(x = "ddenseMatrix", vectors = "missing"),  
           function(x, vectors, ...) callGeneric(as(x, "dgeMatrix")))  
   
 setMethod("Schur", signature(x = "ddenseMatrix", vectors = "logical"),  
           function(x, vectors, ...) callGeneric(as(x, "dgeMatrix"), vectors))  
   
101    
102  setMethod("Math",  .trilDense <- function(x, k = 0, ...) {
           signature(x = "ddenseMatrix"),  
           function(x) callGeneric(as(x, "dgeMatrix")))  
   
   
 ### FIXME: band() et al should be extended from "ddense" to "dense" !  
 ###        However, needs much work to generalize dup_mMatrix_as_dgeMatrix()  
   
 ## NB: have extra tril(), triu() methods for symmetric ["dsy" and "dsp"] and  
 ##     for triangular ["dtr" and "dtp"]  
 setMethod("tril", "ddenseMatrix",  
           function(x, k = 0, ...) {  
103                k <- as.integer(k[1])                k <- as.integer(k[1])
104                dd <- dim(x); sqr <- dd[1] == dd[2]      d <- dim(x)
105                stopifnot(-dd[1] <= k, k <= dd[1]) # had k <= 0      stopifnot(-d[1] <= k, k <= d[1]) # had k <= 0
106                ## returns "lower triangular" if k <= 0 && sqr                ## returns "lower triangular" if k <= 0 && sqr
107                .Call(ddense_band, x, -dd[1], k)      .Call(dense_band, x, -d[1], k)
108            })  }
109    ## NB: have extra tril(), triu() methods for symmetric ["dsy" and "dsp"] and
110    ##     for triangular ["dtr" and "dtp"]
111    setMethod("tril", "denseMatrix", .trilDense)
112    setMethod("tril",      "matrix", .trilDense)
113    
114  setMethod("triu", "ddenseMatrix",  .triuDense <- function(x, k = 0, ...) {
           function(x, k = 0, ...) {  
115                k <- as.integer(k[1])                k <- as.integer(k[1])
116                dd <- dim(x); sqr <- dd[1] == dd[2]      d <- dim(x)
117                stopifnot(-dd[1] <= k, k <= dd[1]) # had k >= 0      stopifnot(-d[1] <= k, k <= d[1]) # had k >= 0
118                ## returns "upper triangular" if k >= 0                ## returns "upper triangular" if k >= 0
119                .Call(ddense_band, x, k, dd[2])      .Call(dense_band, x, k, d[2])
120            })  }
121    setMethod("triu", "denseMatrix", .triuDense)
122    setMethod("triu",      "matrix", .triuDense)
123    
124  setMethod("band", "ddenseMatrix",  .bandDense <- function(x, k1, k2, ...) {
           function(x, k1, k2, ...) {  
125                k1 <- as.integer(k1[1])                k1 <- as.integer(k1[1])
126                k2 <- as.integer(k2[1])                k2 <- as.integer(k2[1])
127                dd <- dim(x); sqr <- dd[1] == dd[2]      dd <- dim(x)
128                stopifnot(-dd[1] <= k1, k1 <= k2, k2 <= dd[1])      sqr <- dd[1] == dd[2]
129                r <- .Call(ddense_band, x, k1, k2)      stopifnot(-dd[1] <= k1, k1 <= k2, k2 <= dd[2])
130                if (k1 < 0  &&  k1 == -k2  && isSymmetric(x)) ## symmetric      r <- .Call(dense_band, x, k1, k2)
131                    as(r, paste(.M.kind(x), "syMatrix", sep=''))      if (sqr &&  k1 < 0 &&  k1 == -k2  && isSymmetric(x)) ## symmetric
132            forceSymmetric(r)
133                else                else
134                    r                    r
135    }
136    setMethod("band", "denseMatrix", .bandDense)
137    setMethod("band",      "matrix", .bandDense)
138    
139    
140    setMethod("symmpart", signature(x = "ddenseMatrix"),
141              function(x) .Call(ddense_symmpart, x))
142    setMethod("skewpart", signature(x = "ddenseMatrix"),
143              function(x) .Call(ddense_skewpart, x))
144    
145    
146    setMethod("is.finite", signature(x = "dgeMatrix"),
147              function(x) {
148                  if(all(ifin <- is.finite(x@x)))
149                      allTrueMat(x)
150                  else if(any(ifin)) {
151                      r <- as(x, "lMatrix") #-> logical x-slot
152                      r@x <- ifin
153                      as(r, "nMatrix")
154                  }
155                  else is.na_nsp(x)
156              })
157    
158    ## TODO? -- rather methods for specific subclasses of ddenseMatrix
159    setMethod("is.finite", signature(x = "ddenseMatrix"),
160              function(x) {
161                  if(all(ifin <- is.finite(x@x))) return(allTrueMat(x))
162                  ## *NOT* dge, i.e., either triangular or symmetric
163                  ## (possibly packed): has finite 0-triangle
164                  cdx <- getClassDef(class(x))
165    
166                  r <- new(if(extends(cdx,"symmetricMatrix"))"nsyMatrix" else "ngeMatrix")
167                  r@Dim <- (d <- x@Dim)
168                  r@Dimnames <- x@Dimnames
169                  isPacked <- (le <- prod(d)) > length(ifin)
170                  r@x <- rep.int(TRUE, le)
171                  iTr <- indTri(d[1], upper= x@uplo == "U", diag= TRUE)
172                  if(isPacked) { ## x@x is "usable"
173                      r@x[iTr] <- ifin
174                  } else {
175                      r@x[iTr] <- ifin[iTr]
176                  }
177                  r
178              })
179    
180    setMethod("is.infinite", signature(x = "ddenseMatrix"),
181              function(x) {
182                  if(any((isInf <- is.infinite(x@x)))) {
183                      r <- as(x, "lMatrix")#-> logical x-slot; 0 |--> FALSE
184                      r@x <- isInf
185                      as(r, "nMatrix")# often sparse .. better way?
186                  }
187                  else is.na_nsp(x)
188            })            })

Legend:
Removed from v.2052  
changed lines
  Added in v.3018

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