SCM

SCM Repository

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

Annotation of /pkg/R/dsparseMatrix.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1226 - (view) (download)

1 : maechler 925 ## For multiplication operations, sparseMatrix overrides other method
2 :     ## selections. Coerce a ddensematrix argument to a dgeMatrix.
3 :    
4 :     setMethod("%*%", signature(x = "dsparseMatrix", y = "ddenseMatrix"),
5 :     function(x, y) callGeneric(x, as(y, "dgeMatrix")))
6 :    
7 :     setMethod("%*%", signature(x = "ddenseMatrix", y = "dsparseMatrix"),
8 :     function(x, y) callGeneric(as(x, "dgeMatrix"), y))
9 :    
10 :     setMethod("crossprod", signature(x = "dsparseMatrix", y = "ddenseMatrix"),
11 :     function(x, y = NULL) callGeneric(x, as(y, "dgeMatrix")))
12 :    
13 :     setMethod("crossprod", signature(x = "ddenseMatrix", y = "dsparseMatrix"),
14 :     function(x, y = NULL) callGeneric(as(x, "dgeMatrix"), y))
15 :    
16 :     ## and coerce dsparse* to dgC*
17 :     setMethod("%*%", signature(x = "dsparseMatrix", y = "dgeMatrix"),
18 :     function(x, y) callGeneric(as(x, "dgCMatrix"), y))
19 :    
20 :     setMethod("%*%", signature(x = "dgeMatrix", y = "dsparseMatrix"),
21 :     function(x, y) callGeneric(x, as(y, "dgCMatrix")))
22 :    
23 :     setMethod("crossprod", signature(x = "dsparseMatrix", y = "dgeMatrix"),
24 :     function(x, y = NULL) callGeneric(as(x, "dgCMatrix"), y))
25 :    
26 :     ## NB: there's already
27 :     ## ("CsparseMatrix", "missing") and ("TsparseMatrix", "missing") methods
28 :    
29 :     setMethod("crossprod", signature(x = "dgeMatrix", y = "dsparseMatrix"),
30 :     function(x, y = NULL) callGeneric(x, as(y, "dgCMatrix")))
31 :    
32 : maechler 946 setMethod("image", "dsparseMatrix",
33 :     function(x, ...) image(as(x, "dgTMatrix"), ...))
34 :    
35 : maechler 956 setMethod("kronecker", signature(X = "dsparseMatrix", Y = "dsparseMatrix"),
36 :     function (X, Y, FUN = "*", make.dimnames = FALSE, ...)
37 :     callGeneric(as(X, "dgTMatrix"),as(Y, "dgTMatrix")))
38 : maechler 946
39 : maechler 956
40 : maechler 925 ## Group Methods, see ?Arith (e.g.)
41 :     ## -----
42 :    
43 : maechler 1226 setMethod("Arith", ## "+", "-", "*", "^", "%%", "%/%", "/"
44 :     signature(e1 = "dsparseMatrix", e2 = "dsparseMatrix"),
45 :     function(e1, e2) callGeneric(as(e1, "dgCMatrix"),
46 :     as(e2, "dgCMatrix")))
47 :     setMethod("Arith",
48 :     signature(e1 = "dsparseMatrix", e2 = "numeric"),
49 :     function(e1, e2) callGeneric(as(e1, "dgCMatrix"), e2))
50 :     setMethod("Arith",
51 :     signature(e1 = "numeric", e2 = "dsparseMatrix"),
52 :     function(e1, e2) callGeneric(e1, as(e2, "dgCMatrix")))
53 : maechler 925
54 :     setMethod("Math",
55 : maechler 946 signature(x = "dsparseMatrix"),
56 :     function(x) {
57 :     r <- callGeneric(as(x, "dgCMatrix"))
58 :     if(is(r, "dsparseMatrix")) as(r, class(x))
59 :     })
60 : maechler 925
61 : maechler 946 if(FALSE) ## unneeded with "Math2" in ./dMatrix.R
62 : maechler 925 setMethod("Math2",
63 : maechler 946 signature(x = "dsparseMatrix", digits = "numeric"),
64 :     function(x, digits) {
65 :     r <- callGeneric(as(x, "dgCMatrix"), digits = digits)
66 :     if(is(r, "dsparseMatrix")) as(r, class(x))
67 :     })
68 : maechler 925
69 :    
70 :     ### cbind2 / rbind2
71 :     if(paste(R.version$major, R.version$minor, sep=".") >= "2.2") {
72 :     ## for R 2.2.x (and later):
73 :    
74 :     ### cbind2
75 :     setMethod("cbind2", signature(x = "dsparseMatrix", y = "numeric"),
76 :     function(x, y) {
77 :     d <- dim(x); nr <- d[1]; nc <- d[2]; cl <- class(x)
78 :     x <- as(x, "dgCMatrix")
79 :     if(nr > 0) {
80 :     y <- rep(y, length.out = nr) # 'silent procrustes'
81 :     n0y <- y != 0
82 :     n.e <- length(x@i)
83 :     x@i <- c(x@i, (0:(nr-1))[n0y])
84 :     x@p <- c(x@p, n.e + sum(n0y))
85 :     x@x <- c(x@x, y[n0y])
86 :     } else { ## nr == 0
87 :    
88 :     }
89 :     x@Dim[2] <- nc + 1:1
90 :     if(is.character(dn <- x@Dimnames[[2]]))
91 :     x@Dimnames[[2]] <- c(dn, "")
92 :     x
93 :     })
94 :     ## the same, (x,y) <-> (y,x):
95 :     setMethod("cbind2", signature(x = "numeric", y = "dsparseMatrix"),
96 :     function(x, y) {
97 :     d <- dim(y); nr <- d[1]; nc <- d[2]; cl <- class(y)
98 :     y <- as(y, "dgCMatrix")
99 :     if(nr > 0) {
100 :     x <- rep(x, length.out = nr) # 'silent procrustes'
101 :     n0x <- x != 0
102 :     y@i <- c((0:(nr-1))[n0x], y@i)
103 :     y@p <- c(0:0, sum(n0x) + y@p)
104 :     y@x <- c(x[n0x], y@x)
105 :     } else { ## nr == 0
106 :    
107 :     }
108 :     y@Dim[2] <- nc + 1:1
109 :     if(is.character(dn <- y@Dimnames[[2]]))
110 :     y@Dimnames[[2]] <- c(dn, "")
111 :     y
112 :     })
113 :    
114 :    
115 :     setMethod("cbind2", signature(x = "dsparseMatrix", y = "matrix"),
116 :     function(x, y) callGeneric(x, as(y, "dgCMatrix")))
117 :     setMethod("cbind2", signature(x = "matrix", y = "dsparseMatrix"),
118 :     function(x, y) callGeneric(as(x, "dgCMatrix"), y))
119 :    
120 :     setMethod("cbind2", signature(x = "dsparseMatrix", y = "dsparseMatrix"),
121 :     function(x, y) {
122 :     nr <- rowCheck(x,y)
123 :     ## beware of (packed) triangular, symmetric, ...
124 : maechler 1226 hasDN <- !all(lapply(c(dnx <- dimnames(x),
125 :     dny <- dimnames(y)), is.null))
126 :     ans <- .Call("Csparse_horzcat",
127 :     as(x, "dgCMatrix"), as(y, "dgCMatrix"))
128 : maechler 925 if(hasDN) {
129 :     ## R and S+ are different in which names they take
130 :     ## if they differ -- but there's no warning in any case
131 :     rn <- if(!is.null(dnx[[1]])) dnx[[1]] else dny[[1]]
132 :     cx <- dnx[[2]] ; cy <- dny[[2]]
133 :     cn <- if(is.null(cx) && is.null(cy)) NULL
134 : bates 1218 else c(if(!is.null(cx)) cx else rep.int("", ncol(x)),
135 :     if(!is.null(cy)) cy else rep.int("", ncol(y)))
136 :     ans@Dimnames <- list(rn, cn)
137 : maechler 925 }
138 : bates 1218 ans
139 : maechler 925 })
140 :    
141 : bates 1218 setMethod("rbind2", signature(x = "dsparseMatrix", y = "dsparseMatrix"),
142 :     function(x, y) {
143 :     nr <- colCheck(x,y)
144 :     ## beware of (packed) triangular, symmetric, ...
145 : maechler 1226 hasDN <- !all(lapply(c(dnx <- dimnames(x),
146 :     dny <- dimnames(y)), is.null))
147 :     ans <- .Call("Csparse_vertcat",
148 :     as(x, "dgCMatrix"), as(y, "dgCMatrix"))
149 : bates 1218 if(hasDN) {
150 :     ## R and S+ are different in which names they take
151 :     ## if they differ -- but there's no warning in any case
152 :     cn <- if(!is.null(dnx[[2]])) dnx[[2]] else dny[[2]]
153 :     rx <- dnx[[1]] ; ry <- dny[[1]]
154 :     rn <- if(is.null(rx) && is.null(ry)) NULL
155 :     else c(if(!is.null(rx)) rx else rep.int("", nrow(x)),
156 :     if(!is.null(ry)) ry else rep.int("", nrow(y)))
157 :     ans@Dimnames <- list(rn, cn)
158 :     }
159 :     ans
160 :     })
161 : maechler 925
162 :     }## R-2.2.x ff

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