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 1672, Mon Nov 6 20:25:10 2006 UTC revision 1673, Mon Nov 6 20:54:26 2006 UTC
# Line 75  Line 75 
75    
76    
77  .ind.prep2 <- function(i, margin, di, dn)  .ind.prep2 <- function(i, margin, di, dn)
78  {  {    ## Purpose: do the ``common things'' for "*gTMatrix" sub-assignment
     ## Purpose: do the ``common things'' for "*gTMatrix" sub-assignment  
79      ##          for 1 dimension, 'margin' ,      ##          for 1 dimension, 'margin' ,
80      ##          and return match(.,.) + li = length of corresponding dimension      ##          and return match(.,.) + li = length of corresponding dimension
81      ##      ##
82      ## i is "index"; margin in {1,2};      ## i is "index"; margin in {1,2};
83      ## di = dim(x)      { used when i is "logical" }      ## di = dim(x)      { used when i is "logical" }
84    
85        ## difference to .ind.prep(): use 1-indices; no match(xi,..), no dn at end
86      dn <- dn[[margin]]      dn <- dn[[margin]]
87      has.dn <- is.character(dn)      has.dn <- is.character(dn)
88      if(is(i, "numeric")) {      if(is(i, "numeric")) {
# Line 120  Line 120 
120  setMethod("[", signature(x = "TsparseMatrix", i = "index", j = "missing",  setMethod("[", signature(x = "TsparseMatrix", i = "index", j = "missing",
121                           drop = "logical"),                           drop = "logical"),
122            function (x, i, j, ..., drop) { ## select rows            function (x, i, j, ..., drop) { ## select rows
123                  if(is(x, "symmetricMatrix"))
124                      x <- as(x, paste(.M.kind(x), "geMatrix", sep=''))
125                ip <- .ind.prep(x@i, i, 1, dim(x), dimnames(x))                ip <- .ind.prep(x@i, i, 1, dim(x), dimnames(x))
126                x@Dim[1] <- ip$li                x@Dim[1] <- ip$li
127                if(!is.null(ip$dn)) x@Dimnames[[1]] <- ip$dn                if(!is.null(ip$dn)) x@Dimnames[[1]] <- ip$dn
# Line 135  Line 137 
137  setMethod("[", signature(x = "TsparseMatrix", i = "missing", j = "index",  setMethod("[", signature(x = "TsparseMatrix", i = "missing", j = "index",
138                           drop = "logical"),                           drop = "logical"),
139            function (x, i, j, ..., drop) { ## select columns            function (x, i, j, ..., drop) { ## select columns
140                  if(is(x, "symmetricMatrix"))
141                      x <- as(x, paste(.M.kind(x), "geMatrix", sep=''))
142                ip <- .ind.prep(x@j, j, 2, dim(x), dimnames(x))                ip <- .ind.prep(x@j, j, 2, dim(x), dimnames(x))
143                x@Dim[2] <- ip$li                x@Dim[2] <- ip$li
144                if(!is.null(ip$dn)) x@Dimnames[[2]] <- ip$dn                if(!is.null(ip$dn)) x@Dimnames[[2]] <- ip$dn
# Line 155  Line 159 
159            ## (i,j, drop) all specified            ## (i,j, drop) all specified
160            di <- dim(x)            di <- dim(x)
161            dn <- dimnames(x)            dn <- dimnames(x)
162              if(is(x, "symmetricMatrix")) {
163                  isSym <- length(i) == length(j) && all(i == j)
164                  ## result is *still* symmetric --> keep symmetry!
165                  if(!isSym)
166                      ## result no longer symmetric -> to "generalMatrix"
167                      x <- as(x, paste(.M.kind(x), "gTMatrix", sep=''))
168              } else isSym <- FALSE
169              if(isSym) {
170                  offD <- x@i != x@j
171                  ip1 <- .ind.prep(c(x@i,x@j[offD]), i, 1, di, dn)
172                  ip2 <- .ind.prep(c(x@j,x@i[offD]), j, 2, di, dn)
173              } else {
174            ip1 <- .ind.prep(x@i, i, 1, di, dn)            ip1 <- .ind.prep(x@i, i, 1, di, dn)
175            ip2 <- .ind.prep(x@j, j, 2, di, dn)            ip2 <- .ind.prep(x@j, j, 2, di, dn)
176              }
177            x@Dim <- nd <- c(ip1$li, ip2$li)            x@Dim <- nd <- c(ip1$li, ip2$li)
178            x@Dimnames <- list(ip1$dn, ip2$dn)            x@Dimnames <- list(ip1$dn, ip2$dn)
179    
180            sel <- ip1$m > 0:0  &  ip2$m > 0:0            sel <- ip1$m > 0:0  &  ip2$m > 0:0
181              if(isSym) { # only those corresponding to upper/lower triangle
182                  sel <- sel &
183                  (if(x@uplo == "U") ip1$m <= ip2$m else ip2$m <= ip1$m)
184              }
185            x@i <- ip1$m[sel] - 1:1            x@i <- ip1$m[sel] - 1:1
186            x@j <- ip2$m[sel] - 1:1            x@j <- ip2$m[sel] - 1:1
187            if (!is(x, "nsparseMatrix")) x@x <- x@x[sel]            if (!is(x, "nsparseMatrix"))
188                  x@x <- c(x@x, if(isSym) x@x[offD])[sel]
189            if (drop && any(nd == 1)) drop(as(x,"matrix")) else x            if (drop && any(nd == 1)) drop(as(x,"matrix")) else x
190        })        })
191    
# Line 190  Line 213 
213      ##    into a *sum* of several ones :      ##    into a *sum* of several ones :
214      x <- uniq(x) # -> ./Auxiliaries.R      x <- uniq(x) # -> ./Auxiliaries.R
215    
216      sel <- ((m1 <- match(x@i, i1, nomatch=0)) > 0:0 &      get.ind.sel <- function(ii,ij)
217              (m2 <- match(x@j, i2, nomatch=0)) > 0:0)          (match(x@i, ii, nomatch = 0) > 0:0 &
218             match(x@j, ij, nomatch = 0) > 0:0)
219    
220        if((sym.x <- is(x, "symmetricMatrix"))) {
221            r.sym <- dind[1] == dind[2] && i1 == i2 &&
222            (lenRepl == 1 || isSymmetric(value <- array(value, dim=dind)))
223            if(r.sym) { ## result is *still* symmetric --> keep symmetry!
224                ## now consider only those indices above / below diagonal:
225                xU <- x@uplo == "U"
226                useI <- if(xU) i1 <= i2 else i2 <= i1
227                i1 <- i1[useI]
228                i2 <- i2[useI]
229                ## select also the corresponding triangle
230                if(lenRepl > 1)
231                    value <- value[(if(xU)upper.tri else lower.tri)(value, diag=TRUE)]
232            }
233            else { # go to "generalMatrix" and continue
234                x <- as(x, paste(.M.kind(x), "gTMatrix", sep=''))
235            }
236        }
237    
238        sel <- get.ind.sel(i1,i2)
239      has.x <- any("x" == slotNames(x)) # i.e. *not* nonzero-pattern      has.x <- any("x" == slotNames(x)) # i.e. *not* nonzero-pattern
240    
241      ## the simplest case: for all Tsparse, even for i or j missing      ## the simplest case: for all Tsparse, even for i or j missing
# Line 224  Line 267 
267          return(x)          return(x)
268      }      }
269    
270      v0 <- is0(value <- rep(value, length = lenRepl))      if(sym.x && r.sym)
271           lenRepl <- length(value) # shorter (since only "triangle")
272        else
273           value <- rep(value, length = lenRepl)
274    
275        v0 <- is0(value)
276      ## value[1:lenRepl]:  which are structural 0 now, which not?      ## value[1:lenRepl]:  which are structural 0 now, which not?
277    
278      if(any(sel)) {      if(any(sel)) {

Legend:
Removed from v.1672  
changed lines
  Added in v.1673

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