SCM

SCM Repository

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

Diff of /pkg/R/Rsparse.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1759, Sat Feb 3 21:07:00 2007 UTC revision 1760, Sat Feb 3 21:13:22 2007 UTC
# Line 7  Line 7 
7    
8  ### contains = "dMatrix"  ### contains = "dMatrix"
9    
10  .R.2.T <- function(from) .Call(compressed_to_TMatrix, from, FALSE)  ## compressed_to_TMatrix -- fails on 32bit--enable-R-shlib with segfault {Kurt}
11    ## ------------ --> ../src/dgCMatrix.c
12    ##_SF_ .R.2.T <- function(from) .Call(compressed_to_TMatrix, from, FALSE)
13    ## slow R-level workaround
14    ## this is cheap; alternative: going there directly, using
15    ##      i <- .Call(Matrix_expand_pointers, from@p),
16    .R.2.T <- function(from) as(.R.2.C(from), "TsparseMatrix")
17    
18  ## R_to_CMatrix -- fails on 32bit--enable-R-shlib with segfault {Kurt}  ## R_to_CMatrix -- fails on 32bit--enable-R-shlib with segfault {Kurt}
19  ## ------------ --> ../src/dgCMatrix.c  ## ------------ --> ../src/dgCMatrix.c
20  .R.2.C <- function(from) .Call(R_to_CMatrix, from)  ##_SF_ .R.2.C <- function(from) .Call(R_to_CMatrix, from)
21  ## "slow" R-level workaround  ## "slow" R-level workaround
22  .R.2.C <- function(from)  .R.2.C <- function(from)
23  {  {
# Line 39  Line 45 
45      r      r
46  }  }
47    
48    ## coercion to other virtual classes --- the functionality we want to encourage
49    
50  setAs("RsparseMatrix", "TsparseMatrix", .R.2.T)  setAs("RsparseMatrix", "TsparseMatrix", .R.2.T)
51  setAs("RsparseMatrix", "CsparseMatrix", .R.2.C)  setAs("RsparseMatrix", "CsparseMatrix", .R.2.C)
52  ## for printing etc:  
53  setAs("RsparseMatrix", "dgeMatrix",  setAs("RsparseMatrix", "denseMatrix",
54        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "dgeMatrix"))        function(from) as(.R.2.C(from), "denseMatrix"))
 setAs("RsparseMatrix", "matrix",  
       function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "matrix"))  
55    
56  setAs("RsparseMatrix", "dsparseMatrix",  setAs("RsparseMatrix", "dsparseMatrix",
57        function(from) as(.Call(R_to_CMatrix, from), "dsparseMatrix"))        function(from) as(.R.2.C(from), "dsparseMatrix"))
58    ##_SF_       function(from) as(.Call(R_to_CMatrix, from), "dsparseMatrix"))
59  setAs("RsparseMatrix", "lsparseMatrix",  setAs("RsparseMatrix", "lsparseMatrix",
60        function(from) as(.Call(R_to_CMatrix, from), "lsparseMatrix"))        function(from) as(.R.2.C(from), "lsparseMatrix"))
61    ##_SF_      function(from) as(.Call(R_to_CMatrix, from), "lsparseMatrix"))
62  setAs("RsparseMatrix", "nsparseMatrix",  setAs("RsparseMatrix", "nsparseMatrix",
63        function(from) as(.Call(R_to_CMatrix, from), "nsparseMatrix"))        function(from) as(.R.2.C(from), "nsparseMatrix"))
64    ##_SF_      function(from) as(.Call(R_to_CMatrix, from), "nsparseMatrix"))
65    
66  setAs("RsparseMatrix", "dMatrix",  setAs("RsparseMatrix", "dMatrix",
67        function(from) as(.Call(R_to_CMatrix, from), "dMatrix"))        function(from) as(.R.2.C(from), "dMatrix"))
68    ##_SF_      function(from) as(.Call(R_to_CMatrix, from), "dMatrix"))
69  setAs("RsparseMatrix", "lMatrix",  setAs("RsparseMatrix", "lMatrix",
70        function(from) as(.Call(R_to_CMatrix, from), "lMatrix"))        function(from) as(.R.2.C(from), "lMatrix"))
71    ##_SF_      function(from) as(.Call(R_to_CMatrix, from), "lMatrix"))
72  setAs("RsparseMatrix", "nMatrix",  setAs("RsparseMatrix", "nMatrix",
73        function(from) as(.Call(R_to_CMatrix, from), "nMatrix"))        function(from) as(.R.2.C(from), "nMatrix"))
74    ##_SF_      function(from) as(.Call(R_to_CMatrix, from), "nMatrix"))
75    
76    
77    ## for printing etc:
78    setAs("RsparseMatrix", "dgeMatrix",
79          function(from) as(.R.2.C(from), "dgeMatrix"))
80    setAs("RsparseMatrix", "matrix",
81          function(from) as(.R.2.C(from), "matrix"))
82    
83    
84  ##--- and all these are just "the essential low-level coercions" : ----------  ##--- and all these are just "the essential low-level coercions" : ----------
85    
# Line 70  Line 90 
90  ## setAs("ngRMatrix", "matrix",  ## setAs("ngRMatrix", "matrix",
91  ##       function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "matrix"))  ##       function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "matrix"))
92    
93  setAs("dgRMatrix", "dgeMatrix",  ## setAs("dgRMatrix", "dgeMatrix",
94        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "dgeMatrix"))  ##       function(from) as(.R.2.C(from), "dgeMatrix"))
95  setAs("lgRMatrix", "lgeMatrix",  ## setAs("lgRMatrix", "lgeMatrix",
96        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "lgeMatrix"))  ##       function(from) as(.R.2.C(from), "lgeMatrix"))
97  setAs("ngRMatrix", "ngeMatrix",  ## setAs("ngRMatrix", "ngeMatrix",
98        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "ngeMatrix"))  ##       function(from) as(.R.2.C(from), "ngeMatrix"))
99    
100  setAs("dgRMatrix", "dgCMatrix", .R.2.C)  ## setAs("dgRMatrix", "dgCMatrix", .R.2.C)
101  setAs("lgRMatrix", "lgCMatrix", .R.2.C)  ## setAs("lgRMatrix", "lgCMatrix", .R.2.C)
102  setAs("ngRMatrix", "ngCMatrix", .R.2.C)  ## setAs("ngRMatrix", "ngCMatrix", .R.2.C)
103  ## really needed? :  ## ## really needed? :
104  setAs("dgRMatrix", "CsparseMatrix", function(from) as(from, "dgCMatrix"))  ## setAs("dgRMatrix", "CsparseMatrix", .R.2.C)
105    
106    
107  setAs("dgRMatrix", "dgTMatrix", .R.2.T)  ## setAs("dgRMatrix", "dgTMatrix", .R.2.T)
108  setAs("lgRMatrix", "lgTMatrix", .R.2.T)  ## setAs("lgRMatrix", "lgTMatrix", .R.2.T)
109  setAs("ngRMatrix", "ngTMatrix", .R.2.T)  ## setAs("ngRMatrix", "ngTMatrix", .R.2.T)
110    
111  ##=== Now the same stories for the "s" (symmetric) and "t" (triangular) ones ===  ##=== Now the same stories for the "s" (symmetric) and "t" (triangular) ones ===
112    
113  setAs("dsRMatrix", "dsCMatrix", .R.2.C)  ## setAs("dsRMatrix", "dsCMatrix", .R.2.C)
114  setAs("lsRMatrix", "lsCMatrix", .R.2.C)  ## setAs("lsRMatrix", "lsCMatrix", .R.2.C)
115  setAs("nsRMatrix", "nsCMatrix", .R.2.C)  ## setAs("nsRMatrix", "nsCMatrix", .R.2.C)
116    
117  setAs("dsRMatrix", "dsTMatrix", .R.2.T)  ## setAs("dsRMatrix", "dsTMatrix", .R.2.T)
118  setAs("lsRMatrix", "lsTMatrix", .R.2.T)  ## setAs("lsRMatrix", "lsTMatrix", .R.2.T)
119  setAs("nsRMatrix", "nsTMatrix", .R.2.T)  ## setAs("nsRMatrix", "nsTMatrix", .R.2.T)
120    
121  setAs("dsRMatrix", "dsyMatrix",  ## setAs("dsRMatrix", "dsyMatrix",
122        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "dsyMatrix"))  ##       function(from) as(.R.2.C(from), "dsyMatrix"))
123  setAs("lsRMatrix", "lsyMatrix",  ## setAs("lsRMatrix", "lsyMatrix",
124        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "lsyMatrix"))  ##       function(from) as(.R.2.C(from), "lsyMatrix"))
125  setAs("nsRMatrix", "nsyMatrix",  ## setAs("nsRMatrix", "nsyMatrix",
126        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "nsyMatrix"))  ##       function(from) as(.R.2.C(from), "nsyMatrix"))
127    
128  setAs("dtRMatrix", "dtCMatrix", .R.2.C)  ## setAs("dtRMatrix", "dtCMatrix", .R.2.C)
129  setAs("ltRMatrix", "ltCMatrix", .R.2.C)  ## setAs("ltRMatrix", "ltCMatrix", .R.2.C)
130  setAs("ntRMatrix", "ntCMatrix", .R.2.C)  ## setAs("ntRMatrix", "ntCMatrix", .R.2.C)
131    
132  setAs("dtRMatrix", "dtTMatrix", .R.2.T)  ## setAs("dtRMatrix", "dtTMatrix", .R.2.T)
133  setAs("ltRMatrix", "ltTMatrix", .R.2.T)  ## setAs("ltRMatrix", "ltTMatrix", .R.2.T)
134  setAs("ntRMatrix", "ntTMatrix", .R.2.T)  ## setAs("ntRMatrix", "ntTMatrix", .R.2.T)
135    
136  setAs("dtRMatrix", "dtrMatrix",  ## setAs("dtRMatrix", "dtrMatrix",
137        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "dtrMatrix"))  ##       function(from) as(.R.2.C(from), "dtrMatrix"))
138  setAs("ltRMatrix", "ltrMatrix",  ## setAs("ltRMatrix", "ltrMatrix",
139        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "ltrMatrix"))  ##       function(from) as(.R.2.C(from), "ltrMatrix"))
140  setAs("ntRMatrix", "ntrMatrix",  ## setAs("ntRMatrix", "ntrMatrix",
141        function(from) as(.Call(compressed_to_TMatrix, from, FALSE), "ntrMatrix"))  ##       function(from) as(.R.2.C(from), "ntrMatrix"))
142    
143  ##setAs("matrix", "dgRMatrix",  ##setAs("matrix", "dgRMatrix",
144  ##      function(from) {  ##      function(from) {
# Line 133  Line 153 
153          p = m@p, j = m@i, x = m@x)          p = m@p, j = m@i, x = m@x)
154  }  }
155    
156  setAs("matrix",    "dgRMatrix", .viaC.to.dgR)  setAs("matrix",    "dgRMatrix", .viaC.to.dgR)## one of the few coercions "to specific"
157  setAs("dgeMatrix", "dgRMatrix", .viaC.to.dgR)  setAs("matrix",    "RsparseMatrix", .viaC.to.dgR)
158  setAs("dgCMatrix", "dgRMatrix", .viaC.to.dgR)  setAs("ddenseMatrix", "RsparseMatrix", .viaC.to.dgR)
159  setAs("dgTMatrix", "dgRMatrix", .viaC.to.dgR)  setAs("dsparseMatrix", "RsparseMatrix", .viaC.to.dgR)
160    
161  ## symmetric: can use same 'p' slot  ## symmetric: can use same 'p' slot
162  setAs("dsCMatrix", "dsRMatrix",  setAs("dsCMatrix", "dsRMatrix",
163        function(from) new("dsRMatrix", Dim = dim(from), Dimnames = .M.DN(from),        function(from) new("dsRMatrix", Dim = dim(from), Dimnames = .M.DN(from),
164                p = from@p, j = from@i, x = from@x,                p = from@p, j = from@i, x = from@x,
165                uplo = if (from@uplo == "U") "L" else "U"))                uplo = if (from@uplo == "U") "L" else "U"))
166    ## FIXME: if this makes sense, do it for "l" and "n" as well as "d"
167    
168  setAs("dtCMatrix", "dtRMatrix", .viaC.to.dgR) # should work; can NOT use 'p'  ## setAs("dtCMatrix", "dtRMatrix", .viaC.to.dgR) # should work; can NOT use 'p'
169    
170    
171  ##setAs("dgRMatrix", "dgeMatrix",  ##setAs("dgRMatrix", "dgeMatrix",
# Line 170  Line 191 
191    
192  setMethod("image", "dgRMatrix",  setMethod("image", "dgRMatrix",
193            function(x, ...) {            function(x, ...) {
194                x <- as(x, "dgTMatrix")                x <- as(x, "TsparseMatrix")
195                callGeneric()                callGeneric()
196            })            })
197    
198  setMethod("t", "RsparseMatrix", function(x) as_Rsparse(t(.R.2.T(x))))  setMethod("t", "RsparseMatrix", function(x) as(t(.R.2.T(x)), "RsparseMatrix"))
199    
200    
201  ## Want tril(), triu(), band() --- just as "indexing" ---  ## Want tril(), triu(), band() --- just as "indexing" ---
202  ## return a "close" class:  ## return a "close" class:
203  setMethod("tril", "RsparseMatrix",  setMethod("tril", "RsparseMatrix",
204            function(x, k = 0, ...) as_Rsparse(tril(.R.2.C(x), k = k, ...)))            function(x, k = 0, ...)
205              as(tril(.R.2.C(x), k = k, ...), "RsparseMatrix"))
206  setMethod("triu", "RsparseMatrix",  setMethod("triu", "RsparseMatrix",
207            function(x, k = 0, ...) as_Rsparse(triu(.R.2.C(x), k = k, ...)))            function(x, k = 0, ...)
208              as(triu(.R.2.C(x), k = k, ...), "RsparseMatrix"))
209  setMethod("band", "RsparseMatrix",  setMethod("band", "RsparseMatrix",
210            function(x, k1, k2, ...)            function(x, k1, k2, ...)
211            as_Rsparse(band(.R.2.C(x), k1 = k1, k2 = k2, ...)))            as(band(.R.2.C(x), k1 = k1, k2 = k2, ...), "RsparseMatrix"))

Legend:
Removed from v.1759  
changed lines
  Added in v.1760

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