SCM

SCM Repository

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

Diff of /pkg/R/Tsparse.R

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

revision 875, Sat Aug 27 21:29:21 2005 UTC revision 886, Wed Aug 31 17:49:47 2005 UTC
# Line 3  Line 3 
3  ### "[" :  ### "[" :
4  ### -----  ### -----
5    
6  ## FIXME: The following is just for numeric indices.  ## Want to allow 'numeric', 'logical' and 'character' indices
7    
8    ## Test for numeric/logical/character
9    ## method-*internally* ; this is not strictly OO, but allows to use
10    ## the following utility and hence much more compact code.
11    
12    .ind.prep <- function(xi, i, margin, di, dn)
13    {
14        ## Purpose: do the ``common things'' for "*gTMatrix" indexing
15        ##          and return match(.,.) + li = length of corresponding dimension
16        ##
17        ## i is "index";  xi = "x@i";  margin in {1,2};
18        ## di = dim(x)      { when i is "logical" }
19        ## dn = dimnames(x)
20    
21        dn <- dn[[margin]]
22        has.dn <- is.character(dn)
23        if(is(i, "numeric")) {
24            storage.mode(i) <- "integer"
25            i0 <- i - 1:1 # tranform to 0-indexing
26            if(has.dn) dn <- dn[i]
27        }
28        else if (is(i, "logical")) {
29            i0 <- (0:(di[margin]-1:1))[i]
30            if(has.dn) dn <- dn[i]
31        } else { ## character
32            if(!has.dn)
33                stop(gettextf(
34                              "no 'dimnames[[%d]]': cannot use character indexing"),
35                     margin, domain = NA)
36            i0 <- match(i, dn, nomatch=0)
37            dn <- dn[i0]
38            i0 <- i0 - 1:1
39        }
40        list(m = match(xi, i0, nomatch=0), li = length(i0), dn = dn)
41    }
42    
43    
44    ## Otherwise have to write methods for all possible combinations of
45    ##  (i , j) \in
46    ##  (numeric, logical, character, missing) x (numeric, log., char., miss.)
47    
 ## Want to allow 'logical' (and 'character' with dimnames; but  
 ## that will be less common for sparse matrices) as well!  
 ## Consider s/numeric/vector/ and then test for numeric/logical/character  
 ## method-*internally* ; this is not strictly OO, but may lead  
 ## to much more compact code  
48    
49  ## Select rows  ## Select rows
50  setMethod("[", signature(x = "gTMatrix", i = "numeric", j = "missing",  setMethod("[", signature(x = "gTMatrix", i = "index", j = "missing",
51                           drop = "logical"),                           drop = "logical"),
52            function (x, i, j, ..., drop) { ## select rows            function (x, i, j, ..., drop) { ## select rows
53                storage.mode(i) <- "integer"                ip <- .ind.prep(x@i, i, 1, dim(x), dimnames(x))
54                xi <- x@i + 1:1 # 1-indexing                x@Dim[1] <- ip$li
55                sel <- xi %in% i                x@Dimnames[1] <- ip$dn
56                nd <- c(length(i), ncol(x))                sel <- ip$m > 0
57                x@Dim <- nd                x@i <- ip$m[sel] - 1:1
               x@i <- match(xi[sel], i) - 1:1  
58                x@j <- x@j[sel]                x@j <- x@j[sel]
59                x@x <- x@x[sel]                x@x <- x@x[sel]
60                if (drop && any(nd == 1)) drop(as(x,"matrix")) else x                if (drop && any(x@Dim == 1:1)) drop(as(x,"matrix")) else x
61            })            })
62    
63    
64  ## Select columns  ## Select columns
65  setMethod("[", signature(x = "gTMatrix", i = "missing", j = "numeric",  setMethod("[", signature(x = "gTMatrix", i = "missing", j = "index",
66                           drop = "logical"),                           drop = "logical"),
67            function (x, i, j, ..., drop) { ## select columns            function (x, i, j, ..., drop) { ## select columns
68                storage.mode(j) <- "integer"                ip <- .ind.prep(x@j, j, 2, dim(x), dimnames(x))
69                xj <- x@j + 1:1 # 1-indexing                x@Dim[2] <- ip$li
70                sel <- xj %in% j                x@Dimnames[2] <- ip$dn
71                nd <- c(nrow(x), length(j))                sel <- ip$m > 0
               x@Dim <- nd  
72                x@i <-  x@i[sel]                x@i <-  x@i[sel]
73                x@j <- match(xj[sel], j) - 1:1                x@j <- ip$m[sel] - 1:1
74                x@x <- x@x[sel]                x@x <- x@x[sel]
75                if (drop && any(nd == 1)) drop(as(x,"matrix")) else x                if (drop && any(x@Dim == 1:1)) drop(as(x,"matrix")) else x
76            })            })
77    
78    
79  ## [.data.frame has : drop = if (missing(i)) TRUE else length(cols) == 1)  ## [.data.frame has : drop = if (missing(i)) TRUE else length(cols) == 1)
80    
81  setMethod("[", signature(x = "gTMatrix",  setMethod("[", signature(x = "gTMatrix",
82                           i = "numeric", j = "numeric", drop = "logical"),                           i = "index", j = "index", drop = "logical"),
83            function (x, i, j, ..., drop)            function (x, i, j, ..., drop)
84        {        {
85            ## (i,j, drop) all specified            ## (i,j, drop) all specified
86            storage.mode(i) <- "integer"            di <- dim(x)
87            storage.mode(j) <- "integer"            dn <- dimnames(x)
88            xi <- x@i + 1:1            ip1 <- .ind.prep(x@i, i, 1, di, dn)
89            xj <- x@j + 1:1            ip2 <- .ind.prep(x@j, j, 2, di, dn)
90            sel <- (xi %in% i) & (xj %in% j)            x@Dim <- nd <- c(ip1$li, ip2$li)
91            nd <- c(length(i), length(j))            x@Dimnames <- list(ip1$dn, ip2$dn)
92            x@Dim <- nd            sel <- ip1$m > 0:0  &  ip2$m > 0:0
93            x@i <- match(xi[sel], i) - 1:1            x@i <- ip1$m[sel] - 1:1
94            x@j <- match(xj[sel], j) - 1:1            x@j <- ip2$m[sel] - 1:1
95            x@x <- x@x[sel]            x@x <- x@x[sel]
96            if (drop && any(nd == 1)) drop(as(x,"matrix")) else x            if (drop && any(nd == 1)) drop(as(x,"matrix")) else x
97        })        })

Legend:
Removed from v.875  
changed lines
  Added in v.886

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