SCM

SCM Repository

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

Diff of /pkg/R/sparseMatrix.R

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

revision 1547, Mon Sep 11 14:49:39 2006 UTC revision 1548, Mon Sep 11 22:13:07 2006 UTC
# Line 55  Line 55 
55            }            }
56            else { ## no weights: 0/1 matrix -> logical            else { ## no weights: 0/1 matrix -> logical
57                as(as(from, "matrix"),                as(as(from, "matrix"),
58                   if(symm) "lsTMatrix" else "lgTMatrix")                   if(symm) "nsTMatrix" else "ngTMatrix")
59            }            }
60        })        })
61    
# Line 85  Line 85 
85                flip <- i > j                flip <- i > j
86                i[flip] <- j[flip]                i[flip] <- j[flip]
87                j[flip] <- tmp[flip]                j[flip] <- tmp[flip]
88                dtm <- new("lsTMatrix", i = i, j = j, Dim = dm,                dtm <- new("nsTMatrix", i = i, j = j, Dim = dm,
89                             Dimnames = list(nd, nd), uplo = "U")                             Dimnames = list(nd, nd), uplo = "U")
90            } else {            } else {
91                dtm <- new("lgTMatrix", i = i, j = j, Dim = dm,                dtm <- new("ngTMatrix", i = i, j = j, Dim = dm,
92                             Dimnames = list(nd, nd))                             Dimnames = list(nd, nd))
93            }            }
94            as(dtm, "CsparseMatrix")            as(dtm, "CsparseMatrix")
# Line 143  Line 143 
143                           drop = "logical"),                           drop = "logical"),
144            function (x, i, j, drop) {            function (x, i, j, drop) {
145                cl <- class(x)                cl <- class(x)
146                viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"                viaCl <- paste(.M.kind(x,cl), "gTMatrix", sep='')
147                x <- callGeneric(x = as(x, viaCl), i=i, drop=drop)                x <- callGeneric(x = as(x, viaCl), i=i, drop=drop)
148                ## try_as(x, c(cl, sub("T","C", viaCl)))                ## try_as(x, c(cl, sub("T","C", viaCl)))
149                if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))                if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
# Line 154  Line 154 
154                           drop = "logical"),                           drop = "logical"),
155            function (x, i, j, drop) {            function (x, i, j, drop) {
156                cl <- class(x)                cl <- class(x)
157                viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"                viaCl <- paste(.M.kind(x,cl), "gTMatrix", sep='')
158                x <- callGeneric(x = as(x, viaCl), j=j, drop=drop)                x <- callGeneric(x = as(x, viaCl), j=j, drop=drop)
159                ## try_as(x, c(cl, sub("T","C", viaCl)))                ## try_as(x, c(cl, sub("T","C", viaCl)))
160                if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))                if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
# Line 165  Line 165 
165                           i = "index", j = "index", drop = "logical"),                           i = "index", j = "index", drop = "logical"),
166            function (x, i, j, drop) {            function (x, i, j, drop) {
167                cl <- class(x)                cl <- class(x)
168                viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"                viaCl <- paste(.M.kind(x,cl), "gTMatrix", sep='')
169                x <- callGeneric(x = as(x, viaCl), i=i, j=j, drop=drop)                x <- callGeneric(x = as(x, viaCl), i=i, j=j, drop=drop)
170                ## try_as(x, c(cl, sub("T","C", viaCl)))                ## try_as(x, c(cl, sub("T","C", viaCl)))
171                if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))                if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
# Line 204  Line 204 
204  setMethod("-", signature(e1 = "sparseMatrix", e2 = "missing"),  setMethod("-", signature(e1 = "sparseMatrix", e2 = "missing"),
205            function(e1) { e1@x <- -e1@x ; e1 })            function(e1) { e1@x <- -e1@x ; e1 })
206  ## with the following exceptions:  ## with the following exceptions:
207  setMethod("-", signature(e1 = "lsparseMatrix", e2 = "missing"),  setMethod("-", signature(e1 = "nsparseMatrix", e2 = "missing"),
208            function(e1) callGeneric(as(e1, "dgCMatrix")))            function(e1) callGeneric(as(e1, "dgCMatrix")))
209  setMethod("-", signature(e1 = "pMatrix", e2 = "missing"),  setMethod("-", signature(e1 = "pMatrix", e2 = "missing"),
210            function(e1) callGeneric(as(e1, "lgTMatrix")))            function(e1) callGeneric(as(e1, "ngTMatrix")))
211    
212  ## Group method  "Arith"  ## Group method  "Arith"
213    
# Line 247  Line 247 
247      } else {      } else {
248          m <- as(object, "matrix")          m <- as(object, "matrix")
249      }      }
250      logi <- is(object,"lsparseMatrix")      logi <- is(object,"lsparseMatrix") || is(object,"nsparseMatrix")
251      if(logi)      if(logi)
252          x <- array(character(length(m)), dim(m), dimnames=dimnames(m))          x <- array(character(length(m)), dim(m), dimnames=dimnames(m))
253      else {      else {
# Line 309  Line 309 
309                    ## test for exact equality; FIXME(?): identical() too strict?                    ## test for exact equality; FIXME(?): identical() too strict?
310                    identical(as(object, "lgCMatrix"),                    identical(as(object, "lgCMatrix"),
311                              as(t(object), "lgCMatrix"))                              as(t(object), "lgCMatrix"))
312                  else if (is(object, "nMatrix"))
313                      ## test for exact equality; FIXME(?): identical() too strict?
314                      identical(as(object, "ngCMatrix"),
315                                as(t(object), "ngCMatrix"))
316                else stop("not yet implemented")                else stop("not yet implemented")
317            })            })
318    

Legend:
Removed from v.1547  
changed lines
  Added in v.1548

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