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

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