SCM

SCM Repository

[matrix] Annotation of /pkg/R/ldenseMatrix.R
ViewVC logotype

Annotation of /pkg/R/ldenseMatrix.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1575 - (view) (download)

1 : maechler 1201 #### "ldenseMatrix" - virtual class of logical dense matrices
2 :     #### ------------
3 : maechler 1575 #### Contains lge*; ltr*, ltp*; lsy*, lsp*; ldi*
4 : maechler 1201
5 :     ## Logical -> Double {of same structure}:
6 :    
7 : maechler 946 setAs("lgeMatrix", "dgeMatrix", l2d_Matrix)
8 : maechler 1201 setAs("lsyMatrix", "dsyMatrix", l2d_Matrix)
9 :     setAs("lspMatrix", "dspMatrix", l2d_Matrix)
10 : maechler 946 setAs("ltrMatrix", "dtrMatrix", l2d_Matrix)
11 :     setAs("ltpMatrix", "dtpMatrix", l2d_Matrix)
12 :    
13 : maechler 1548 ### NOTA BENE: Much of this is *very* parallel to ./ndenseMatrix.R
14 :     ### ~~~~~~~~~~~~~~~~
15 :    
16 : maechler 1201 ## all need be coercable to "lgeMatrix":
17 :    
18 : maechler 1575 setAs("lsyMatrix", "lgeMatrix", function(from)
19 : maechler 1548 .Call(lsyMatrix_as_lgeMatrix, from, 0:0))
20 : maechler 1575 setAs("ltrMatrix", "lgeMatrix", function(from)
21 : maechler 1548 .Call(ltrMatrix_as_lgeMatrix, from, 0:0))
22 : maechler 1201 setAs("ltpMatrix", "lgeMatrix",
23 :     function(from) as(as(from, "ltrMatrix"), "lgeMatrix"))
24 :     setAs("lspMatrix", "lgeMatrix",
25 :     function(from) as(as(from, "lsyMatrix"), "lgeMatrix"))
26 : maechler 1282 ## and the reverse
27 :     setAs("lgeMatrix", "ltpMatrix",
28 :     function(from) as(as(from, "ltrMatrix"), "ltpMatrix"))
29 :     setAs("lgeMatrix", "lspMatrix",
30 :     function(from) as(as(from, "lsyMatrix"), "lspMatrix"))
31 : maechler 1201
32 : maechler 1282
33 : maechler 1201 ## packed <-> non-packed :
34 :    
35 : maechler 946 setAs("lspMatrix", "lsyMatrix",
36 : bates 1038 function(from)
37 : maechler 1548 .Call(lspMatrix_as_lsyMatrix, from, 0:0))
38 : bates 1038
39 : maechler 946 setAs("lsyMatrix", "lspMatrix",
40 : bates 1038 function(from)
41 : maechler 1548 .Call(lsyMatrix_as_lspMatrix, from, 0:0))
42 : maechler 946
43 :     setAs("ltpMatrix", "ltrMatrix",
44 : bates 1038 function(from)
45 : maechler 1548 .Call(ltpMatrix_as_ltrMatrix, from, 0:0))
46 : bates 1038
47 : maechler 946 setAs("ltrMatrix", "ltpMatrix",
48 : bates 1038 function(from)
49 : maechler 1548 .Call(ltrMatrix_as_ltpMatrix, from, 0:0))
50 : maechler 946
51 :    
52 : maechler 1282
53 : maechler 1201 ### -> symmetric :
54 : maechler 946
55 : maechler 1548 if(FALSE) ## not sure if this is a good idea ... -- FIXME?
56 : maechler 1201 setIs("lgeMatrix", "lsyMatrix",
57 : maechler 1548 test = function(obj) isSymmetric(obj),
58 :     replace = function(obj, value) { ## copy all slots
59 : maechler 1575 for(n in slotNames(obj)) slot(obj, n) <- slot(value, n)
60 : maechler 1201 })
61 :    
62 :     ### Alternative (at least works):
63 :     setAs("lgeMatrix", "lsyMatrix",
64 :     function(from) {
65 :     if(isSymmetric(from))
66 :     new("lsyMatrix", x = from@x, Dim = from@Dim,
67 :     Dimnames = from@Dimnames, factors = from@factors)
68 :     else stop("not a symmetric matrix")
69 :     })
70 :    
71 : maechler 1226 setAs("lgeMatrix", "ltrMatrix",
72 :     function(from) {
73 :     if(isT <- isTriangular(from))
74 :     new("ltrMatrix", x = from@x, Dim = from@Dim,
75 :     Dimnames = from@Dimnames, uplo = attr(isT, "kind"))
76 : maechler 1575 ## TODO: also check 'diag'
77 : maechler 1226 else stop("not a triangular matrix")
78 :     })
79 : maechler 1201
80 : maechler 1226
81 : maechler 1201 ### ldense* <-> "matrix" :
82 :    
83 :     ## 1) "lge* :
84 :     setAs("lgeMatrix", "matrix",
85 :     function(from) array(from@x, dim = from@Dim, dimnames = from@Dimnames))
86 :    
87 :     setAs("matrix", "lgeMatrix",
88 :     function(from) {
89 :     new("lgeMatrix",
90 :     x = as.logical(from),
91 :     Dim = as.integer(dim(from)),
92 : maechler 1332 Dimnames = .M.DN(from))
93 : maechler 1201 })
94 :    
95 :     ## 2) base others on "lge*":
96 :    
97 :     setAs("matrix", "lsyMatrix",
98 :     function(from) as(as(from, "lgeMatrix"), "lsyMatrix"))
99 : maechler 1226 setAs("matrix", "lspMatrix",
100 :     function(from) as(as(from, "lsyMatrix"), "lspMatrix"))
101 :     setAs("matrix", "ltrMatrix",
102 :     function(from) as(as(from, "lgeMatrix"), "ltrMatrix"))
103 :     setAs("matrix", "ltpMatrix",
104 :     function(from) as(as(from, "ltrMatrix"), "ltpMatrix"))
105 : maechler 1201
106 : maechler 1226 ## Useful if this was called e.g. for as(*, "lsyMatrix"), but it isn't
107 :     setAs("matrix", "ldenseMatrix", function(from) as(from, "lgeMatrix"))
108 :    
109 : maechler 1201 setAs("ldenseMatrix", "matrix", ## uses the above l*M. -> lgeM.
110 :     function(from) as(as(from, "lgeMatrix"), "matrix"))
111 :    
112 :     ## dense |-> compressed :
113 :    
114 :     setAs("lgeMatrix", "lgTMatrix",
115 :     function(from) {
116 : maechler 1575 ## Non'zeros':
117 :     nF <- nonFALSE(from@x)## == nz.NA(from@x, na. = TRUE)
118 :     ## cheap but not so efficient:
119 :     d <- dim(from)
120 :     ij <- which(array(nF, dim = d), arr.ind = TRUE) - 1:1
121 :     new("lgTMatrix", i = ij[,1], j = ij[,2], x = from@x[nF],
122 :     Dim = d, Dimnames = from@Dimnames,
123 :     factors = from@factors)
124 : maechler 1201 })
125 :    
126 : maechler 1285 setAs("lgeMatrix", "lgCMatrix",
127 :     function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))
128 :    
129 : maechler 1391 setMethod("as.logical", signature(x = "ldenseMatrix"),
130 :     function(x, ...) as(x, "lgeMatrix")@x)
131 :    
132 : maechler 1201 ###----------------------------------------------------------------------
133 :    
134 :    
135 : maechler 946 setMethod("t", signature(x = "lgeMatrix"), t_geMatrix)
136 :     setMethod("t", signature(x = "ltrMatrix"), t_trMatrix)
137 :     setMethod("t", signature(x = "lsyMatrix"), t_trMatrix)
138 :     setMethod("t", signature(x = "ltpMatrix"),
139 : maechler 1575 function(x) as(callGeneric(as(x, "ltrMatrix")), "ltpMatrix"))
140 : maechler 946 setMethod("t", signature(x = "lspMatrix"),
141 : maechler 1575 function(x) as(callGeneric(as(x, "lsyMatrix")), "lspMatrix"))
142 : maechler 954
143 :     setMethod("!", "ltrMatrix",
144 : maechler 1282 function(e1) {
145 :     e1@x <- !e1@x
146 :     ## And now we must fill one triangle with '!FALSE' results :
147 : maechler 954
148 : maechler 1282 ## TODO: the following should be .Call using
149 :     ## a variation of make_array_triangular:
150 :     r <- as(e1, "lgeMatrix")
151 :     n <- e1@Dim[1]
152 :     coli <- rep(1:n, each=n)
153 :     rowi <- rep(1:n, n)
154 :     Udiag <- e1@diag == "U"
155 :     log.i <-
156 :     if(e1@uplo == "U") {
157 :     if(Udiag) rowi >= coli else rowi > coli
158 :     } else {
159 :     if(Udiag) rowi <= coli else rowi < coli
160 :     }
161 :     r@x[log.i] <- TRUE
162 :     r
163 :     })
164 : maechler 954
165 : maechler 1282 setMethod("!", "ltpMatrix", function(e1) !as(e1, "ltrMatrix"))
166 : maechler 954
167 : maechler 1548 ## for the other ldense* ones
168 :     setMethod("!", "lgeMatrix",
169 : maechler 1575 function(e1) { e1@x <- !e1@x ; e1 })
170 : maechler 1548 ## FIXME : this loses symmetry "lsy" and "lsp":
171 : maechler 954 setMethod("!", "ldenseMatrix",
172 : maechler 1575 function(e1) !as(e1, "lgeMatrix"))
173 : maechler 1201
174 : maechler 1548
175 :     setMethod("|", signature(e1="lgeMatrix", e2="lgeMatrix"),
176 :     function(e1,e2) {
177 :     d <- dimCheck(e1, e2)
178 :     e1@x <- e1@x | e2@x
179 :     e1
180 :     })
181 :     setMethod("&", signature(e1="lgeMatrix", e2="lgeMatrix"),
182 :     function(e1,e2) {
183 :     d <- dimCheck(e1, e2)
184 :     e1@x <- e1@x & e2@x
185 :     e1
186 :     })
187 :    
188 :     setMethod("|", signature(e1="ldenseMatrix", e2="ldenseMatrix"),
189 :     function(e1,e2) {
190 :     d <- dimCheck(e1, e2)
191 :     as(e1, "lgeMatrix") | as(e2, "lgeMatrix")
192 :     })
193 :    
194 :     setMethod("&", signature(e1="ldenseMatrix", e2="ldenseMatrix"),
195 :     function(e1,e2) {
196 :     d <- dimCheck(e1, e2)
197 :     as(e1, "lgeMatrix") & as(e2, "lgeMatrix")
198 :     })
199 :    
200 :    
201 : maechler 1201 setMethod("as.vector", signature(x = "ldenseMatrix", mode = "missing"),
202 : maechler 1575 function(x) as(x, "lgeMatrix")@x)

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