SCM

SCM Repository

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

Annotation of /pkg/Matrix/R/ddenseMatrix.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1460 - (view) (download)
Original Path: pkg/R/ddenseMatrix.R

1 : bates 686 ### Define Methods that can be inherited for all subclasses
2 :    
3 : maechler 1447 ## This replaces many "d..Matrix" -> "dgeMatrix" ones
4 :     ## >> but << needs all sub(sub(sub)) classes of "ddenseMatrix" listed
5 :     ## ----- in ../src/Mutils.c
6 : bates 1460
7 :     ## Should this method return 'from' without duplication when it has
8 :     ## class dgeMatrix?
9 : maechler 1447 setAs("ddenseMatrix", "dgeMatrix",
10 :     function(from) .Call(dup_mMatrix_as_dgeMatrix, from))
11 :    
12 :     ## d(ouble) to l(ogical):
13 : maechler 956 setAs("dgeMatrix", "lgeMatrix", d2l_Matrix)
14 :     setAs("dtrMatrix", "ltrMatrix", d2l_Matrix)
15 :     setAs("dtpMatrix", "ltpMatrix", d2l_Matrix)
16 :     setAs("dsyMatrix", "lsyMatrix", d2l_Matrix)
17 :     setAs("dspMatrix", "lspMatrix", d2l_Matrix)
18 :    
19 : bates 1460 setAs("ddenseMatrix", "CsparseMatrix",
20 :     function(from) {
21 :     if (class(from) != "dgeMatrix")
22 :     from <- .Call(dup_mMatrix_as_dgeMatrix, from)
23 :     .Call(dense_to_Csparse, from)
24 :     })
25 :    
26 :     ## special case
27 :     setAs("dgeMatrix", "dgCMatrix",
28 :     function(from) .Call(dense_to_Csparse, from))
29 :    
30 :     setAs("matrix", "CsparseMatrix",
31 :     function(from)
32 :     .Call(dense_to_Csparse, .Call(dup_mMatrix_as_dgeMatrix, from)))
33 :    
34 :     ## special case needed in the Matrix function
35 :     setAs("matrix", "dgCMatrix",
36 :     function(from) {
37 :     storage.mode(from) <- "double"
38 :     .Call(dense_to_Csparse, from)
39 :     })
40 :    
41 :     setAs("numeric", "CsparseMatrix",
42 :     function(from)
43 :     .Call(dense_to_Csparse, .Call(dup_mMatrix_as_dgeMatrix, from)))
44 :    
45 : maechler 1391 setMethod("as.numeric", signature(x = "ddenseMatrix"),
46 :     function(x, ...) as(x, "dgeMatrix")@x)
47 :    
48 : maechler 792 ## -- see also ./Matrix.R e.g., for a show() method
49 :    
50 : bates 686 ## These methods are the 'fallback' methods for all dense numeric
51 : maechler 792 ## matrices in that they simply coerce the ddenseMatrix to a
52 :     ## dgeMatrix. Methods for special forms override these.
53 : bates 686
54 :     setMethod("norm", signature(x = "ddenseMatrix", type = "missing"),
55 :     function(x, type, ...) callGeneric(as(x, "dgeMatrix")))
56 :    
57 :     setMethod("norm", signature(x = "ddenseMatrix", type = "character"),
58 :     function(x, type, ...) callGeneric(as(x, "dgeMatrix"), type))
59 :    
60 :     setMethod("rcond", signature(x = "ddenseMatrix", type = "missing"),
61 :     function(x, type, ...) callGeneric(as(x, "dgeMatrix")))
62 :    
63 :     setMethod("rcond", signature(x = "ddenseMatrix", type = "character"),
64 :     function(x, type, ...) callGeneric(as(x, "dgeMatrix"), type))
65 :    
66 : maechler 946 ## Not really useful; now require *identical* class for result:
67 :     ## setMethod("t", signature(x = "ddenseMatrix"),
68 :     ## function(x) callGeneric(as(x, "dgeMatrix")))
69 : bates 686
70 : maechler 1087 setMethod("tcrossprod", signature(x = "ddenseMatrix", y = "missing"),
71 :     function(x, y = NULL) callGeneric(as(x, "dgeMatrix")))
72 : bates 686
73 :     setMethod("crossprod", signature(x = "ddenseMatrix", y = "missing"),
74 :     function(x, y = NULL) callGeneric(as(x, "dgeMatrix")))
75 :    
76 :     setMethod("diag", signature(x = "ddenseMatrix"),
77 :     function(x = 1, nrow, ncol = n) callGeneric(as(x, "dgeMatrix")))
78 :    
79 :     setMethod("solve", signature(a = "ddenseMatrix", b = "missing"),
80 :     function(a, b, ...) callGeneric(as(a, "dgeMatrix")))
81 :    
82 :     setMethod("solve", signature(a = "ddenseMatrix", b = "ANY"),
83 :     function(a, b, ...) callGeneric(as(a, "dgeMatrix"), b))
84 :    
85 :     setMethod("lu", signature(x = "ddenseMatrix"),
86 :     function(x, ...) callGeneric(as(x, "dgeMatrix")))
87 :    
88 : maechler 856 setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "missing"),
89 : bates 686 function(x, logarithm, ...) callGeneric(as(x, "dgeMatrix")))
90 :    
91 : maechler 856 setMethod("determinant", signature(x = "ddenseMatrix", logarithm = "logical"),
92 : bates 686 function(x, logarithm, ...)
93 :     callGeneric(as(x, "dgeMatrix"), logarithm))
94 :    
95 : maechler 954 ## now done for "dMatrix":
96 :     ## setMethod("expm", signature(x = "ddenseMatrix"),
97 :     ## function(x) callGeneric(as(x, "dgeMatrix")))
98 : bates 686
99 :     setMethod("Schur", signature(x = "ddenseMatrix", vectors = "missing"),
100 :     function(x, vectors, ...) callGeneric(as(x, "dgeMatrix")))
101 :    
102 :     setMethod("Schur", signature(x = "ddenseMatrix", vectors = "logical"),
103 :     function(x, vectors, ...) callGeneric(as(x, "dgeMatrix"), vectors))
104 :    
105 : maechler 792
106 : maechler 1331 ## Cheap version: work via "dgeMatrix" and use the group methods there:
107 :     ## FIXME(?): try to preserve "symmetric", "triangular", ...
108 :     setMethod("Arith", ## "+", "-", "*", "^", "%%", "%/%", "/"
109 :     signature(e1 = "ddenseMatrix", e2 = "ddenseMatrix"),
110 :     function(e1, e2) callGeneric(as(e1, "dgeMatrix"),
111 :     as(e2, "dgeMatrix")))
112 :     setMethod("Arith",
113 :     signature(e1 = "ddenseMatrix", e2 = "numeric"),
114 :     function(e1, e2) callGeneric(as(e1, "dgeMatrix"), e2))
115 :     setMethod("Arith",
116 :     signature(e1 = "numeric", e2 = "ddenseMatrix"),
117 :     function(e1, e2) callGeneric(e1, as(e2, "dgeMatrix")))
118 : maechler 908
119 : maechler 1331 setMethod("Math",
120 :     signature(x = "ddenseMatrix"),
121 :     function(x) callGeneric(as(x, "dgeMatrix")))
122 :    
123 :    
124 :    
125 :     ### for R 2.2.x (and later): -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
126 :    
127 : maechler 925 ### cbind2
128 : maechler 1331 setMethod("cbind2", signature(x = "ddenseMatrix", y = "numeric"),
129 :     function(x, y) {
130 :     d <- dim(x); nr <- d[1]; nc <- d[2]
131 :     y <- rep(y, length.out = nr) # 'silent procrustes'
132 :     ## beware of (packed) triangular, symmetric, ...
133 :     x <- as(x, "dgeMatrix")
134 :     x@x <- c(x@x, as.double(y))
135 :     x@Dim[2] <- nc + 1:1
136 :     if(is.character(dn <- x@Dimnames[[2]]))
137 :     x@Dimnames[[2]] <- c(dn, "")
138 :     x
139 :     })
140 :     ## the same, (x,y) <-> (y,x):
141 :     setMethod("cbind2", signature(x = "numeric", y = "ddenseMatrix"),
142 :     function(x, y) {
143 :     d <- dim(y); nr <- d[1]; nc <- d[2]
144 :     x <- rep(x, length.out = nr)
145 :     y <- as(y, "dgeMatrix")
146 :     y@x <- c(as.double(x), y@x)
147 :     y@Dim[2] <- nc + 1:1
148 :     if(is.character(dn <- y@Dimnames[[2]]))
149 :     y@Dimnames[[2]] <- c("", dn)
150 :     y
151 :     })
152 : maechler 908
153 : maechler 1331 setMethod("cbind2", signature(x = "ddenseMatrix", y = "matrix"),
154 :     function(x, y) callGeneric(x, as(y, "dgeMatrix")))
155 :     setMethod("cbind2", signature(x = "matrix", y = "ddenseMatrix"),
156 :     function(x, y) callGeneric(as(x, "dgeMatrix"), y))
157 : maechler 908
158 : maechler 1331 setMethod("cbind2", signature(x = "ddenseMatrix", y = "ddenseMatrix"),
159 :     function(x, y) {
160 :     nr <- rowCheck(x,y)
161 :     ncx <- x@Dim[2]
162 :     ncy <- y@Dim[2]
163 :     ## beware of (packed) triangular, symmetric, ...
164 :     hasDN <- !is.null(dnx <- dimnames(x)) |
165 :     !is.null(dny <- dimnames(y))
166 :     x <- as(x, "dgeMatrix")
167 :     y <- as(y, "dgeMatrix")
168 :     x@x <- c(x@x, y@x)
169 :     x@Dim[2] <- ncx + ncy
170 :     if(hasDN) {
171 :     ## R and S+ are different in which names they take
172 :     ## if they differ -- but there's no warning in any case
173 :     rn <- if(!is.null(dnx[[1]])) dnx[[1]] else dny[[1]]
174 :     cx <- dnx[[2]] ; cy <- dny[[2]]
175 :     cn <- if(is.null(cx) && is.null(cy)) NULL
176 :     else c(if(!is.null(cx)) cx else rep.int("", ncx),
177 :     if(!is.null(cy)) cy else rep.int("", ncy))
178 :     x@Dimnames <- list(rn, cn)
179 :     }
180 :     x
181 :     })
182 : maechler 908
183 : maechler 925 ### rbind2 -- analogous to cbind2 --- more to do for @x though:
184 : maechler 908
185 : maechler 1331 setMethod("rbind2", signature(x = "ddenseMatrix", y = "numeric"),
186 :     function(x, y) {
187 :     if(is.character(dn <- x@Dimnames[[1]])) dn <- c(dn, "")
188 :     new("dgeMatrix", Dim = x@Dim + 1:0,
189 :     Dimnames = list(dn, x@Dimnames[[2]]),
190 :     x = c(rbind2(as(x,"matrix"), y)))
191 :     })
192 :     ## the same, (x,y) <-> (y,x):
193 :     setMethod("rbind2", signature(x = "numeric", y = "ddenseMatrix"),
194 :     function(x, y) {
195 :     if(is.character(dn <- y@Dimnames[[1]])) dn <- c("", dn)
196 :     new("dgeMatrix", Dim = y@Dim + 1:0,
197 :     Dimnames = list(dn, y@Dimnames[[2]]),
198 :     x = c(rbind2(x, as(y,"matrix"))))
199 :     })
200 : maechler 925
201 : maechler 1331 setMethod("rbind2", signature(x = "ddenseMatrix", y = "matrix"),
202 :     function(x, y) callGeneric(x, as(y, "dgeMatrix")))
203 :     setMethod("rbind2", signature(x = "matrix", y = "ddenseMatrix"),
204 :     function(x, y) callGeneric(as(x, "dgeMatrix"), y))
205 : maechler 925
206 : maechler 1331 setMethod("rbind2", signature(x = "ddenseMatrix", y = "ddenseMatrix"),
207 :     function(x, y) {
208 :     nc <- colCheck(x,y)
209 :     nrx <- x@Dim[1]
210 :     nry <- y@Dim[1]
211 :     dn <-
212 :     if(!is.null(dnx <- dimnames(x)) |
213 :     !is.null(dny <- dimnames(y))) {
214 :     ## R and S+ are different in which names they take
215 :     ## if they differ -- but there's no warning in any case
216 :     list(if(is.null(rx <- dnx[[1]]) && is.null(ry <- dny[[1]]))
217 :     NULL else
218 :     c(if(!is.null(rx)) rx else rep.int("", nrx),
219 :     if(!is.null(ry)) ry else rep.int("", nry)),
220 :     if(!is.null(dnx[[2]])) dnx[[2]] else dny[[2]])
221 : maechler 925
222 : maechler 1331 } else list(NULL, NULL)
223 :     ## beware of (packed) triangular, symmetric, ...
224 :     new("dgeMatrix", Dim = c(nrx + nry, nc), Dimnames = dn,
225 :     x = c(rbind2(as(x,"matrix"), as(y,"matrix"))))
226 :     })
227 : bates 1453 ## NB: have extra tril(), triu() methods for symmetric ["dsy" and "dsp"] and
228 :     ## for triangular ["dtr" and "dtp"]
229 :     setMethod("tril", "ddenseMatrix",
230 :     function(x, k = 0, ...) {
231 :     k <- as.integer(k[1])
232 :     dd <- dim(x); sqr <- dd[1] == dd[2]
233 :     stopifnot(-dd[1] <= k, k <= dd[1]) # had k <= 0
234 :     ## returns "lower triangular" if k <= 0 && sqr
235 :     .Call(ddense_band, x, -dd[1], k)
236 :     })
237 :    
238 :     setMethod("triu", "ddenseMatrix",
239 :     function(x, k = 0, ...) {
240 :     k <- as.integer(k[1])
241 :     dd <- dim(x); sqr <- dd[1] == dd[2]
242 :     stopifnot(-dd[1] <= k, k <= dd[1]) # had k >= 0
243 :     ## returns "upper triangular" if k >= 0
244 :     .Call(ddense_band, x, k, dd[2])
245 :     })
246 :    
247 :     setMethod("band", "ddenseMatrix",
248 :     function(x, k1, k2, ...) {
249 :     k1 <- as.integer(k1[1])
250 :     k2 <- as.integer(k2[1])
251 :     dd <- dim(x); sqr <- dd[1] == dd[2]
252 :     stopifnot(-dd[1] <= k1, k1 <= k2, k2 <= dd[1])
253 :     r <- .Call(ddense_band, x, k1, k2)
254 :     if (k1 < 0 && k1 == -k2 && isSymmetric(x)) ## symmetric
255 :     as(r, paste(.M.kind(x), "syMatrix", sep=''))
256 :     else
257 :     r
258 :     })

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