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 1911 - (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 1760 ## compressed_to_TMatrix -- fails on 32bit--enable-R-shlib with segfault {Kurt}
11 :     ## ------------ --> ../src/dgCMatrix.c
12 : maechler 1766 .R.2.T <- function(from) .Call(compressed_to_TMatrix, from, FALSE)
13 : maechler 1760 ## slow R-level workaround
14 :     ## this is cheap; alternative: going there directly, using
15 :     ## i <- .Call(Matrix_expand_pointers, from@p),
16 : maechler 1766 if(FALSE)
17 : maechler 1760 .R.2.T <- function(from) as(.R.2.C(from), "TsparseMatrix")
18 : maechler 1758
19 : maechler 1911 ## R_to_CMatrix
20 : maechler 1758 ## ------------ --> ../src/dgCMatrix.c
21 : maechler 1766 .R.2.C <- function(from) .Call(R_to_CMatrix, from)
22 : maechler 1911
23 : maechler 1766 if(FALSE)## "slow" R-level workaround
24 : maechler 1758 .R.2.C <- function(from)
25 :     {
26 :     cl <- class(from)
27 :     valid <- c("dgRMatrix", "dsRMatrix", "dtRMatrix",
28 :     "lgRMatrix", "lsRMatrix", "ltRMatrix",
29 :     "ngRMatrix", "nsRMatrix", "ntRMatrix",
30 :     "zgRMatrix", "zsRMatrix", "ztRMatrix")
31 : maechler 1832 icl <- match(cl, valid) - 1L
32 : maechler 1758 if(is.na(icl)) stop("invalid class:", cl)
33 :     Ccl <- sub("^(..)R","\\1C", cl) # corresponding Csparse class name
34 :     r <- new(Ccl)
35 :     r@Dim <- rev(from@Dim)
36 :     if(icl %/% 3 != 2) ## not "n..Matrix" --> has 'x' slot
37 :     r@x <- from@x
38 :     if(icl %% 3 != 0) { # symmetric or triangular
39 :     r@uplo <- from@uplo
40 :     if(icl %% 3 == 2) # triangular
41 :     r@diag <- from@diag
42 :     }
43 :     r@i <- from@j
44 :     r@p <- from@p
45 :     r <- t(r)
46 :     r@Dimnames <- from@Dimnames
47 :     r
48 :     }
49 : bates 677
50 : maechler 1911 ## However, a quick way to "treat a t(<R..>) as corresponding <C..> " :
51 :     .tR.2.C <- function(from)
52 :     {
53 :     cl <- class(from)
54 :     valid <- c("dgRMatrix", "dsRMatrix", "dtRMatrix",
55 :     "lgRMatrix", "lsRMatrix", "ltRMatrix",
56 :     "ngRMatrix", "nsRMatrix", "ntRMatrix",
57 :     "zgRMatrix", "zsRMatrix", "ztRMatrix")
58 :     icl <- match(cl, valid) - 1L
59 :     if(is.na(icl)) stop("invalid class:", cl)
60 :     Ccl <- sub("^(..)R","\\1C", cl) # corresponding Csparse class name
61 :     r <- new(Ccl)
62 :     r@i <- from@j
63 :     ##- -
64 :     r@p <- from@p
65 :     r@Dim <- rev(from@Dim)
66 :     r@Dimnames <- rev(from@Dimnames)
67 :    
68 :     if(icl %/% 3 != 2) ## not "n..Matrix" --> has 'x' slot
69 :     r@x <- from@x
70 :     if(icl %% 3 != 0) { # symmetric or triangular
71 :     r@uplo <- from@uplo
72 :     if(icl %% 3 == 2) # triangular
73 :     r@diag <- from@diag
74 :     }
75 :     r
76 :     }
77 :    
78 :    
79 :    
80 : maechler 1760 ## coercion to other virtual classes --- the functionality we want to encourage
81 :    
82 : maechler 1751 setAs("RsparseMatrix", "TsparseMatrix", .R.2.T)
83 :     setAs("RsparseMatrix", "CsparseMatrix", .R.2.C)
84 : maechler 1329
85 : maechler 1760 setAs("RsparseMatrix", "denseMatrix",
86 :     function(from) as(.R.2.C(from), "denseMatrix"))
87 :    
88 : maechler 1751 setAs("RsparseMatrix", "dsparseMatrix",
89 : maechler 1760 function(from) as(.R.2.C(from), "dsparseMatrix"))
90 : maechler 1751 setAs("RsparseMatrix", "lsparseMatrix",
91 : maechler 1760 function(from) as(.R.2.C(from), "lsparseMatrix"))
92 : maechler 1751 setAs("RsparseMatrix", "nsparseMatrix",
93 : maechler 1760 function(from) as(.R.2.C(from), "nsparseMatrix"))
94 : maechler 1751
95 :     setAs("RsparseMatrix", "dMatrix",
96 : maechler 1760 function(from) as(.R.2.C(from), "dMatrix"))
97 : maechler 1751 setAs("RsparseMatrix", "lMatrix",
98 : maechler 1760 function(from) as(.R.2.C(from), "lMatrix"))
99 : maechler 1751 setAs("RsparseMatrix", "nMatrix",
100 : maechler 1760 function(from) as(.R.2.C(from), "nMatrix"))
101 : maechler 1751
102 : maechler 1760
103 :     ## for printing etc:
104 :     setAs("RsparseMatrix", "dgeMatrix",
105 :     function(from) as(.R.2.C(from), "dgeMatrix"))
106 :     setAs("RsparseMatrix", "matrix",
107 :     function(from) as(.R.2.C(from), "matrix"))
108 :    
109 : maechler 1332 ## **VERY** cheap substitutes: work via dgC and t(.)
110 : maechler 1751 .viaC.to.dgR <- function(from) {
111 : maechler 1332 m <- as(t(from), "dgCMatrix")
112 :     new("dgRMatrix", Dim = dim(from), Dimnames = .M.DN(from),
113 : maechler 1734 p = m@p, j = m@i, x = m@x)
114 : maechler 1332 }
115 :    
116 : maechler 1760 setAs("matrix", "dgRMatrix", .viaC.to.dgR)## one of the few coercions "to specific"
117 :     setAs("matrix", "RsparseMatrix", .viaC.to.dgR)
118 :     setAs("ddenseMatrix", "RsparseMatrix", .viaC.to.dgR)
119 :     setAs("dsparseMatrix", "RsparseMatrix", .viaC.to.dgR)
120 : maechler 1332
121 : maechler 1751 ## symmetric: can use same 'p' slot
122 : maechler 1734 setAs("dsCMatrix", "dsRMatrix",
123 :     function(from) new("dsRMatrix", Dim = dim(from), Dimnames = .M.DN(from),
124 :     p = from@p, j = from@i, x = from@x,
125 :     uplo = if (from@uplo == "U") "L" else "U"))
126 : maechler 1760 ## FIXME: if this makes sense, do it for "l" and "n" as well as "d"
127 : maechler 1332
128 : maechler 1760 ## setAs("dtCMatrix", "dtRMatrix", .viaC.to.dgR) # should work; can NOT use 'p'
129 : maechler 1332
130 : maechler 1734
131 : maechler 1332 ##setAs("dgRMatrix", "dgeMatrix",
132 :     ## function(from) .Call(csc_to_dgeMatrix, from))
133 :    
134 :     ##setAs("matrix", "dgRMatrix",
135 :     ## function(from) {
136 :     ## storage.mode(from) <- "double"
137 :     ## .Call(matrix_to_csc, from)
138 :     ## })
139 :    
140 :    
141 : maechler 1747 ##setMethod("diag", signature(x = "dgRMatrix"),
142 :     ## function(x = 1, nrow, ncol = n) .Call(csc_getDiag, x))
143 :    
144 : maechler 1189 ## try to define for "Matrix" -- once and for all -- but that fails -- why? __ FIXME __
145 :     ## setMethod("dim", signature(x = "dgRMatrix"),
146 :     ## function(x) x@Dim, valueClass = "integer")
147 : bates 677
148 :     ##setMethod("t", signature(x = "dgRMatrix"),
149 : maechler 1280 ## function(x) .Call(csc_transpose, x),
150 : bates 677 ## valueClass = "dgRMatrix")
151 :    
152 :     setMethod("image", "dgRMatrix",
153 :     function(x, ...) {
154 : maechler 1760 x <- as(x, "TsparseMatrix")
155 : bates 677 callGeneric()
156 :     })
157 : maechler 1349
158 : maechler 1760 setMethod("t", "RsparseMatrix", function(x) as(t(.R.2.T(x)), "RsparseMatrix"))
159 : maechler 1349
160 : maechler 1655
161 : maechler 1349 ## Want tril(), triu(), band() --- just as "indexing" ---
162 :     ## return a "close" class:
163 :     setMethod("tril", "RsparseMatrix",
164 : maechler 1760 function(x, k = 0, ...)
165 :     as(tril(.R.2.C(x), k = k, ...), "RsparseMatrix"))
166 : maechler 1349 setMethod("triu", "RsparseMatrix",
167 : maechler 1760 function(x, k = 0, ...)
168 :     as(triu(.R.2.C(x), k = k, ...), "RsparseMatrix"))
169 : maechler 1349 setMethod("band", "RsparseMatrix",
170 :     function(x, k1, k2, ...)
171 : maechler 1760 as(band(.R.2.C(x), k1 = k1, k2 = k2, ...), "RsparseMatrix"))

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