SCM

SCM Repository

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

Diff of /pkg/R/dgCMatrix.R

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

revision 1225, Mon Mar 13 14:06:17 2006 UTC revision 1226, Mon Mar 13 14:07:58 2006 UTC
# Line 86  Line 86 
86  ## Group Methods, see ?Arith (e.g.)  ## Group Methods, see ?Arith (e.g.)
87  ## -----  ## -----
88    
 ### TODO:  
   
 if(FALSE) ## FIXME  
89  setMethod("Arith", ##  "+", "-", "*", "^", "%%", "%/%", "/"  setMethod("Arith", ##  "+", "-", "*", "^", "%%", "%/%", "/"
90            signature(e1 = "dgCMatrix", e2 = "dgCMatrix"),            signature(e1 = "dgCMatrix", e2 = "dgCMatrix"),
91            function(e1, e2) {            function(e1, e2) {
# Line 97  Line 94 
94                ij1 <- non0ind(e1)                ij1 <- non0ind(e1)
95                ij2 <- non0ind(e2)                ij2 <- non0ind(e2)
96                switch(.Generic,                switch(.Generic,
97                       "+" =, "-" =, "*" =                       "+" = , "-" =
98                       new("dgTMatrix", Dim = d, Dimnames = dn,                       ## special "T" convention: repeated entries are *summed*
99                           i = c(ij1[,1], ij2[,1]),                       as(new("dgTMatrix", Dim = d, Dimnames = dn,
                          j = c(ij1[,2], ij2[,2]),  
                          x = c(callGeneric(e1@x, 0), callGeneric(0, e2@x)))  
                      ,  
                      "^" = { ## X^0 |-> 1 (also for X=0)  
                          r <- new("dgTMatrix", Dim = d, Dimnames = dn,  
100                                    i = c(ij1[,1], ij2[,1]),                                    i = c(ij1[,1], ij2[,1]),
101                                    j = c(ij1[,2], ij2[,2]),                                    j = c(ij1[,2], ij2[,2]),
102                                    x = c(rep.int(1, nrow(ij1)), 0 ^ e2@x))                              x = c(callGeneric(e1@x, 0), callGeneric(0,e2@x))),
103                           ...                          "dgCMatrix"),
104    
105                         "*" =
106                     { ##  X * 0 == 0 * X == 0 --> keep common non-0
107                         ii <- WhichintersectInd(ij1, ij2, nrow=d[1])
108                         ij <- ij1[ii[[1]], , drop = FALSE]
109                         as(new("dgTMatrix", Dim = d, Dimnames = dn,
110                                i = ij[,1],
111                                j = ij[,2],
112                                x = e1@x[ii[[1]]] * e2@x[ii[[2]]]),
113                            "dgCMatrix")
114                       },                       },
115                       "%%" = , "%/%" = , "/" = {## 0 op 0  |-> NaN  
116                           ...                       "^" =
117                       })                   {
118                         ii <- WhichintersectInd(ij1, ij2, nrow=d[1])
119                         ## 3 cases:
120                         ## 1) X^0 := 1  (even for X=0) ==> dense
121                         ## 2) 0^Y := 0  for Y != 0         =====
122                         ## 3) x^y :
123    
124                         ## FIXME:  dgeM[cbind(i,j)] <- V  is not yet possible
125                         ##     nor dgeM[ i_vect   ] <- V
126                         ## r <- as(e2, "dgeMatrix")
127                         ## ...
128                         r <- as(e2, "matrix")
129                         Yis0 <- r == 0
130                         r[complementInd(ij1, dim=d)] <- 0      ## 2)
131                         r[1:1 + ij2[ii[[2]], , drop=FALSE]] <-
132                             e1@x[ii[[1]]] ^ e2@x[ii[[2]]]      ## 3)
133                         r[Yis0] <- 1                           ## 1)
134                         as(r, "dgeMatrix")
135                     },
136    
137                         "%%" = , "%/%" = , "/" = ## 0 op 0  |-> NaN => dense
138                         callGeneric(as(e1, "dgeMatrix"), e2)
139                         )
140            })            })
141    
142  setMethod("Arith",  setMethod("Arith",
143            signature(e1 = "dgCMatrix", e2 = "numeric"),            signature(e1 = "dgCMatrix", e2 = "numeric"),
144            function(e1, e2) {            function(e1, e2) {
145                if(length(e2) == 1) {                if(length(e2) == 1) { ## e.g.,  Mat ^ a
146                    f0 <- callGeneric(0, e2)                    f0 <- callGeneric(0, e2)
147                    if(!is.na(f0) && f0 == 0.) {                    if(!is.na(f0) && f0 == 0.) { # remain sparse
148                        e1@x <- callGeneric(e1@x, e2)                        e1@x <- callGeneric(e1@x, e2)
149                        e1                        e1
150                    } else {                    } else { ## non-sparse, since '0 o e2' is not 0
151    
152                        ## FIXME: dgeMatrix [cbind(i,j)] <- .. is not yet possible                        ## FIXME: dgeMatrix [cbind(i,j)] <- .. is not yet possible
153                        ##                  r <- as(e1, "dgeMatrix")                        ##                  r <- as(e1, "dgeMatrix")
154                        ##                  r[] <- f0                        ##                  r[] <- f0
# Line 193  Line 218 
218  ###---- end {Group Methods} -----------------  ###---- end {Group Methods} -----------------
219    
220    
221    replCmat <- function (x, i, j, value)
222    {
223        di <- dim(x)
224        dn <- dimnames(x)
225        i1 <- if(missing(i)) 0:(di[1] - 1:1) else .ind.prep2(i, 1, di, dn)
226        i2 <- if(missing(j)) 0:(di[2] - 1:1) else .ind.prep2(j, 2, di, dn)
227        dind <- c(length(i1), length(i2)) # dimension of replacement region
228        lenRepl <- prod(dind)
229        lenV <- length(value)
230        if(lenV == 0) {
231            if(lenRepl != 0)
232                stop("nothing to replace with")
233            else return(x)
234        }
235        ## else: lenV := length(value)       is > 0
236        if(lenRepl %% lenV != 0)
237            stop("number of items to replace is not a multiple of replacement length")
238        if(lenV > lenRepl)
239            stop("too many replacement values")
240    
241        xj <- .Call("Matrix_expand_pointers", x@p, PACKAGE = "Matrix")
242        sel <- (!is.na(match(x@i, i1)) &
243                !is.na(match( xj, i2)))
244    
245        if(sum(sel) == lenRepl) { ## all are already non-zero
246            ## replace them (when value != 0):
247            v0 <- 0 == (value <- rep(value, length = lenRepl))
248            x@x[sel[!v0]] <- value[!v0]
249            return(x)
250        }
251        ## else go via dgT
252        x <- as(x, "dgTMatrix")
253        x[i,j] <- value
254        as(x, "dgCMatrix")
255    }
256    
257    ### TODO (FIXME): almost the same for  "lgCMatrix" and "logical"
258    
259    setReplaceMethod("[", signature(x = "dgCMatrix", i = "index", j = "missing",
260                                    value = "numeric"),
261                     function (x, i, value) replCmat(x, i=i, value=value))
262    
263    setReplaceMethod("[", signature(x = "dgCMatrix", i = "missing", j = "index",
264                                    value = "numeric"),
265                     function (x, j, value) replCmat(x, j=j, value=value))
266    
267    setReplaceMethod("[", signature(x = "dgCMatrix", i = "index", j = "index",
268                                    value = "numeric"),
269                     replCmat)
270    
271    
272    
273    
274  setMethod("writeHB", signature(obj = "dgCMatrix"),  setMethod("writeHB", signature(obj = "dgCMatrix"),
275            function(obj, file, ...)            function(obj, file, ...)

Legend:
Removed from v.1225  
changed lines
  Added in v.1226

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge