SCM

SCM Repository

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

Annotation of /pkg/R/Rsparse.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1758 - (view) (download)

1 : bates 677 #### Sparse Matrices in Compressed row-oriented format
2 : maechler 1599 #### --- "R"
3 : bates 677
4 : maechler 1734 ### ``mainly for completeness'' --- we *do* favour Csparse
5 :     ## - - - - - - - - - - - - hence only "minimal" methods here !
6 :     ## see also ./SparseM-conv.R
7 :    
8 : bates 677 ### contains = "dMatrix"
9 :    
10 : maechler 1751 .R.2.T <- function(from) .Call(compressed_to_TMatrix, from, FALSE)
11 : maechler 1758
12 :     ## R_to_CMatrix -- fails on 32bit--enable-R-shlib with segfault {Kurt}
13 :     ## ------------ --> ../src/dgCMatrix.c
14 : maechler 1751 .R.2.C <- function(from) .Call(R_to_CMatrix, from)
15 : maechler 1758 ## "slow" R-level workaround
16 :     .R.2.C <- function(from)
17 :     {
18 :     cl <- class(from)
19 :     valid <- c("dgRMatrix", "dsRMatrix", "dtRMatrix",
20 :     "lgRMatrix", "lsRMatrix", "ltRMatrix",
21 :     "ngRMatrix", "nsRMatrix", "ntRMatrix",
22 :     "zgRMatrix", "zsRMatrix", "ztRMatrix")
23 :     icl <- match(cl, valid) - 1:1
24 :     if(is.na(icl)) stop("invalid class:", cl)
25 :     Ccl <- sub("^(..)R","\\1C", cl) # corresponding Csparse class name
26 :     r <- new(Ccl)
27 :     r@Dim <- rev(from@Dim)
28 :     if(icl %/% 3 != 2) ## not "n..Matrix" --> has 'x' slot
29 :     r@x <- from@x
30 :     if(icl %% 3 != 0) { # symmetric or triangular
31 :     r@uplo <- from@uplo
32 :     if(icl %% 3 == 2) # triangular
33 :     r@diag <- from@diag
34 :     }
35 :     r@i <- from@j
36 :     r@p <- from@p
37 :     r <- t(r)
38 :     r@Dimnames <- from@Dimnames
39 :     r
40 :     }
41 : bates 677
42 : maechler 1751 setAs("RsparseMatrix", "TsparseMatrix", .R.2.T)
43 :     setAs("RsparseMatrix", "CsparseMatrix", .R.2.C)
44 :     ## for printing etc:
45 :     setAs("RsparseMatrix", "dgeMatrix",
46 :     function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "dgeMatrix"))
47 :     setAs("RsparseMatrix", "matrix",
48 :     function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "matrix"))
49 : maechler 1329
50 : maechler 1751 setAs("RsparseMatrix", "dsparseMatrix",
51 :     function(from) as(.Call(R_to_CMatrix, from), "dsparseMatrix"))
52 :     setAs("RsparseMatrix", "lsparseMatrix",
53 :     function(from) as(.Call(R_to_CMatrix, from), "lsparseMatrix"))
54 :     setAs("RsparseMatrix", "nsparseMatrix",
55 :     function(from) as(.Call(R_to_CMatrix, from), "nsparseMatrix"))
56 :    
57 :     setAs("RsparseMatrix", "dMatrix",
58 :     function(from) as(.Call(R_to_CMatrix, from), "dMatrix"))
59 :     setAs("RsparseMatrix", "lMatrix",
60 :     function(from) as(.Call(R_to_CMatrix, from), "lMatrix"))
61 :     setAs("RsparseMatrix", "nMatrix",
62 :     function(from) as(.Call(R_to_CMatrix, from), "nMatrix"))
63 :    
64 : maechler 1747 ##--- and all these are just "the essential low-level coercions" : ----------
65 :    
66 : maechler 1751 ## setAs("dgRMatrix", "matrix",
67 :     ## function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "matrix"))
68 :     ## setAs("lgRMatrix", "matrix",
69 :     ## function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "matrix"))
70 :     ## setAs("ngRMatrix", "matrix",
71 :     ## function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "matrix"))
72 : bates 677
73 : maechler 1747 setAs("dgRMatrix", "dgeMatrix",
74 :     function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "dgeMatrix"))
75 :     setAs("lgRMatrix", "lgeMatrix",
76 :     function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "lgeMatrix"))
77 :     setAs("ngRMatrix", "ngeMatrix",
78 :     function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "ngeMatrix"))
79 : bates 677
80 : maechler 1751 setAs("dgRMatrix", "dgCMatrix", .R.2.C)
81 :     setAs("lgRMatrix", "lgCMatrix", .R.2.C)
82 :     setAs("ngRMatrix", "ngCMatrix", .R.2.C)
83 : maechler 1747 ## really needed? :
84 :     setAs("dgRMatrix", "CsparseMatrix", function(from) as(from, "dgCMatrix"))
85 :    
86 :    
87 : maechler 1751 setAs("dgRMatrix", "dgTMatrix", .R.2.T)
88 :     setAs("lgRMatrix", "lgTMatrix", .R.2.T)
89 :     setAs("ngRMatrix", "ngTMatrix", .R.2.T)
90 : maechler 1747
91 : maechler 1751 ##=== Now the same stories for the "s" (symmetric) and "t" (triangular) ones ===
92 :    
93 :     setAs("dsRMatrix", "dsCMatrix", .R.2.C)
94 :     setAs("lsRMatrix", "lsCMatrix", .R.2.C)
95 :     setAs("nsRMatrix", "nsCMatrix", .R.2.C)
96 :    
97 :     setAs("dsRMatrix", "dsTMatrix", .R.2.T)
98 :     setAs("lsRMatrix", "lsTMatrix", .R.2.T)
99 :     setAs("nsRMatrix", "nsTMatrix", .R.2.T)
100 :    
101 : maechler 1747 setAs("dsRMatrix", "dsyMatrix",
102 : maechler 1751 function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "dsyMatrix"))
103 : maechler 1747 setAs("lsRMatrix", "lsyMatrix",
104 : maechler 1751 function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "lsyMatrix"))
105 : maechler 1747 setAs("nsRMatrix", "nsyMatrix",
106 : maechler 1751 function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "nsyMatrix"))
107 : maechler 1747
108 : maechler 1751 setAs("dtRMatrix", "dtCMatrix", .R.2.C)
109 :     setAs("ltRMatrix", "ltCMatrix", .R.2.C)
110 :     setAs("ntRMatrix", "ntCMatrix", .R.2.C)
111 :    
112 :     setAs("dtRMatrix", "dtTMatrix", .R.2.T)
113 :     setAs("ltRMatrix", "ltTMatrix", .R.2.T)
114 :     setAs("ntRMatrix", "ntTMatrix", .R.2.T)
115 :    
116 : maechler 1747 setAs("dtRMatrix", "dtrMatrix",
117 : maechler 1751 function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "dtrMatrix"))
118 : maechler 1747 setAs("ltRMatrix", "ltrMatrix",
119 : maechler 1751 function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "ltrMatrix"))
120 : maechler 1747 setAs("ntRMatrix", "ntrMatrix",
121 : maechler 1751 function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "ntrMatrix"))
122 : maechler 1747
123 : bates 677 ##setAs("matrix", "dgRMatrix",
124 :     ## function(from) {
125 :     ## storage.mode(from) <- "double"
126 : maechler 1280 ## .Call(matrix_to_csc, from)
127 : bates 677 ## })
128 :    
129 : maechler 1332 ## **VERY** cheap substitutes: work via dgC and t(.)
130 : maechler 1751 .viaC.to.dgR <- function(from) {
131 : maechler 1332 m <- as(t(from), "dgCMatrix")
132 :     new("dgRMatrix", Dim = dim(from), Dimnames = .M.DN(from),
133 : maechler 1734 p = m@p, j = m@i, x = m@x)
134 : maechler 1332 }
135 :    
136 : maechler 1751 setAs("matrix", "dgRMatrix", .viaC.to.dgR)
137 :     setAs("dgeMatrix", "dgRMatrix", .viaC.to.dgR)
138 :     setAs("dgCMatrix", "dgRMatrix", .viaC.to.dgR)
139 :     setAs("dgTMatrix", "dgRMatrix", .viaC.to.dgR)
140 : maechler 1332
141 : maechler 1751 ## symmetric: can use same 'p' slot
142 : maechler 1734 setAs("dsCMatrix", "dsRMatrix",
143 :     function(from) new("dsRMatrix", Dim = dim(from), Dimnames = .M.DN(from),
144 :     p = from@p, j = from@i, x = from@x,
145 :     uplo = if (from@uplo == "U") "L" else "U"))
146 : maechler 1332
147 : maechler 1751 setAs("dtCMatrix", "dtRMatrix", .viaC.to.dgR) # should work; can NOT use 'p'
148 : maechler 1332
149 : maechler 1734
150 : maechler 1332 ##setAs("dgRMatrix", "dgeMatrix",
151 :     ## function(from) .Call(csc_to_dgeMatrix, from))
152 :    
153 :     ##setAs("matrix", "dgRMatrix",
154 :     ## function(from) {
155 :     ## storage.mode(from) <- "double"
156 :     ## .Call(matrix_to_csc, from)
157 :     ## })
158 :    
159 :    
160 : maechler 1747 ##setMethod("diag", signature(x = "dgRMatrix"),
161 :     ## function(x = 1, nrow, ncol = n) .Call(csc_getDiag, x))
162 :    
163 : maechler 1189 ## try to define for "Matrix" -- once and for all -- but that fails -- why? __ FIXME __
164 :     ## setMethod("dim", signature(x = "dgRMatrix"),
165 :     ## function(x) x@Dim, valueClass = "integer")
166 : bates 677
167 :     ##setMethod("t", signature(x = "dgRMatrix"),
168 : maechler 1280 ## function(x) .Call(csc_transpose, x),
169 : bates 677 ## valueClass = "dgRMatrix")
170 :    
171 :     setMethod("image", "dgRMatrix",
172 :     function(x, ...) {
173 : maechler 1189 x <- as(x, "dgTMatrix")
174 : bates 677 callGeneric()
175 :     })
176 : maechler 1349
177 : maechler 1751 setMethod("t", "RsparseMatrix", function(x) as_Rsparse(t(.R.2.T(x))))
178 : maechler 1349
179 : maechler 1655
180 : maechler 1349 ## Want tril(), triu(), band() --- just as "indexing" ---
181 :     ## return a "close" class:
182 :     setMethod("tril", "RsparseMatrix",
183 : maechler 1751 function(x, k = 0, ...) as_Rsparse(tril(.R.2.C(x), k = k, ...)))
184 : maechler 1349 setMethod("triu", "RsparseMatrix",
185 : maechler 1751 function(x, k = 0, ...) as_Rsparse(triu(.R.2.C(x), k = k, ...)))
186 : maechler 1349 setMethod("band", "RsparseMatrix",
187 :     function(x, k1, k2, ...)
188 : maechler 1751 as_Rsparse(band(.R.2.C(x), k1 = k1, k2 = k2, ...)))

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