SCM

SCM Repository

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

Diff of /pkg/R/Matrix.R

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

revision 2110, Sat Jan 26 20:59:26 2008 UTC revision 2185, Sat Apr 26 20:33:16 2008 UTC
# Line 36  Line 36 
36    
37  ## slow "fall back" method {subclasses should have faster ones}:  ## slow "fall back" method {subclasses should have faster ones}:
38  setMethod("as.vector", signature(x = "Matrix", mode = "missing"),  setMethod("as.vector", signature(x = "Matrix", mode = "missing"),
39            function(x) as.vector(as(x, "matrix")))            function(x, mode) as.vector(as(x, "matrix"), mode))
40    
41  ## mainly need these for "dMatrix" or "lMatrix" respectively, but why not general:  ## mainly need these for "dMatrix" or "lMatrix" respectively, but why not general:
42  setMethod("as.numeric", signature(x = "Matrix"),  setMethod("as.numeric", signature(x = "Matrix"),
# Line 44  Line 44 
44  setMethod("as.logical", signature(x = "Matrix"),  setMethod("as.logical", signature(x = "Matrix"),
45            function(x, ...) as.logical(as.vector(x)))            function(x, ...) as.logical(as.vector(x)))
46    
47    setMethod("mean", signature(x = "Matrix"),
48              function(x, trim = 0, ...) ## TODO: provide 'sparseMatrix method
49              if(is0(trim)) sum(x, ...) / length(x)
50              else mean(as.numeric(x), ...))
51    
52  setMethod("cov2cor", signature(V = "Matrix"),  setMethod("cov2cor", signature(V = "Matrix"),
53            function(V) as(cov2cor(as(V, "matrix")), "dpoMatrix"))            function(V) { ## was as(cov2cor(as(V, "matrix")), "dpoMatrix"))
54                  r <- V
55                  p <- (d <- dim(V))[1]
56                  if(p != d[2]) stop("'V' is not a square matrix")
57                  Is <- sqrt(1/diag(V)) # diag( 1/sigma_i )
58                  if(any(!is.finite(Is)))
59                      warning("diag(.) had 0 or NA entries; non-finite result is doubtful")
60                  Is <- Diagonal(x = Is)
61                  r <- Is %*% V %*% Is
62                  r[cbind(1L:p,1L:p)] <- 1 # exact in diagonal
63                  as(forceSymmetric(r), "dpoMatrix")
64              })
65    
66  ## "base" has an isSymmetric() S3-generic since R 2.3.0  ## "base" has an isSymmetric() S3-generic since R 2.3.0
67  setMethod("isSymmetric", signature(object = "symmetricMatrix"),  setMethod("isSymmetric", signature(object = "symmetricMatrix"),
68            function(object,tol) TRUE)            function(object, ...) TRUE)
69  setMethod("isSymmetric", signature(object = "triangularMatrix"),  setMethod("isSymmetric", signature(object = "triangularMatrix"),
70            ## TRUE iff diagonal:            ## TRUE iff diagonal:
71            function(object,tol) isDiagonal(object))            function(object, ...) isDiagonal(object))
   
 setMethod("isTriangular", signature(object = "triangularMatrix"),  
           function(object, ...) TRUE)  
72    
73  setMethod("isTriangular", signature(object = "matrix"), isTriMat)  setMethod("isTriangular", signature(object = "matrix"), isTriMat)
74    
75  setMethod("isDiagonal", signature(object = "matrix"), .is.diagonal)  setMethod("isDiagonal", signature(object = "matrix"), .is.diagonal)
76    
77    ## The "catch all" methods -- far from optimal:
78    setMethod("symmpart", signature(x = "Matrix"),
79              function(x) as((x + t(x))/2, "symmetricMatrix"))
80    setMethod("skewpart", signature(x = "Matrix"),
81              function(x) (x - t(x))/2)
82    
83    ## FIXME: do this (similarly as for "ddense.." in C
84    setMethod("symmpart", signature(x = "matrix"), function(x) (x + t(x))/2)
85    setMethod("skewpart", signature(x = "matrix"), function(x) (x - t(x))/2)
86    
87    
88    
89    
90  setMethod("dim", signature(x = "Matrix"),  setMethod("dim", signature(x = "Matrix"),
# Line 101  Line 125 
125  ##        "!" is in ./not.R  ##        "!" is in ./not.R
126    
127    
128  Matrix <-  Matrix <- function (data = NA, nrow = 1, ncol = 1, byrow = FALSE,
129      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL,                      dimnames = NULL, sparse = NULL, forceCheck = FALSE)
               sparse = NULL, forceCheck = FALSE)  
130  {  {
131      sparseDefault <- function(m) prod(dim(m)) > 2*sum(isN0(as(m, "matrix")))      sparseDefault <- function(m) prod(dim(m)) > 2*sum(isN0(as(m, "matrix")))
132    
# Line 112  Line 135 
135          class(data) <- "matrix" # "matrix" first for S4 dispatch          class(data) <- "matrix" # "matrix" first for S4 dispatch
136      if(is.null(sparse1 <- sparse) && (i.M || is(data, "matrix")))      if(is.null(sparse1 <- sparse) && (i.M || is(data, "matrix")))
137          sparse <- sparseDefault(data)          sparse <- sparseDefault(data)
138        sM <- FALSE
139      doDN <- TRUE      doDN <- TRUE
140      if (i.M) {      if (i.M) {
141          if(!missing(nrow) || !missing(ncol)|| !missing(byrow))          if(!missing(nrow) || !missing(ncol)|| !missing(byrow))
# Line 131  Line 154 
154              ## Matrix(0, ...) : always sparse unless "sparse = FALSE":              ## Matrix(0, ...) : always sparse unless "sparse = FALSE":
155              if(is.null(sparse)) sparse1 <- sparse <- TRUE              if(is.null(sparse)) sparse1 <- sparse <- TRUE
156              i.M <- sM <- TRUE              i.M <- sM <- TRUE
157                isSym <- nrow == ncol
158              ## will be sparse: do NOT construct full matrix!              ## will be sparse: do NOT construct full matrix!
159              data <- new(if(is.numeric(data)) "dgTMatrix" else              data <- new(paste(if(is.numeric(data)) "d" else
160                          if(is.logical(data)) "lgTMatrix" else                                if(is.logical(data)) "l" else
161                          stop("invalid 'data'"),                          stop("invalid 'data'"),
162                                  if(isSym) "s" else "g", "CMatrix", sep=''),
163                            p = rep.int(0L, ncol+1L),
164                          Dim = as.integer(c(nrow,ncol)),                          Dim = as.integer(c(nrow,ncol)),
165                          Dimnames = if(is.null(dimnames)) list(NULL,NULL)                          Dimnames = if(is.null(dimnames)) list(NULL,NULL)
166                          else dimnames)                          else dimnames)
# Line 162  Line 188 
188          isTri <- isTriangular(data)          isTri <- isTriangular(data)
189      isDiag <- isSym # cannot be diagonal if it isn't symmetric      isDiag <- isSym # cannot be diagonal if it isn't symmetric
190      if(isDiag)      if(isDiag)
191          isDiag <- isDiagonal(data)          isDiag <- !isTRUE(sparse1) && isDiagonal(data)
192    
193      ## Find proper matrix class 'cl'      ## try to coerce ``via'' virtual classes
194      cl <-      if(isDiag) { ## diagonal is preferred to sparse !
195          if(isDiag && !isTRUE(sparse1))          data <- as(data, "diagonalMatrix")
196              "diagonalMatrix" # -> will automatically check for type          isSym <- FALSE
197          else {      } else if(sparse && !sM)
             ## consider it's type  
             ctype <-  
                 if(is(data,"Matrix")) class(data)  
                 else {  
                     if("complex" == (ctype <- typeof(data)))  
                         "z" else ctype  
                 }  
             ctype <- substr(ctype, 1,1) # "d", "l", "i" or "z"  
             if(ctype == "z")  
                 stop("complex matrices not yet implemented in Matrix package")  
             if(ctype == "i") {  
                 warning("integer matrices not yet implemented in 'Matrix'; ",  
                         "using 'double' ones'")  
                 ctype <- "d"  
             }  
             paste(ctype,  
                   if(sparse) {  
                       if(isSym) "sCMatrix" else  
                       if(isTri) "tCMatrix" else "gCMatrix"  
                   } else { ## dense  
                       if(isSym) "syMatrix" else  
                       if(isTri) "trMatrix" else "geMatrix"  
                   }, sep="")  
         }  
   
     ## Can we coerce and be done?  
     if(!canCoerce(data,cl)) { ## try to coerce ``via'' virtual classes  
         if(sparse && !sM)  
198              data <- as(data, "sparseMatrix")              data <- as(data, "sparseMatrix")
199          else if(!sparse && !is(data, "denseMatrix"))      else if(!sparse) {
200            if(i.M) { ## data is 'Matrix'
201                if(!is(data, "denseMatrix"))
202              data <- as(data, "denseMatrix")              data <- as(data, "denseMatrix")
203          if(isTri && !is(data, "triangularMatrix"))          } else { ## data is "matrix" (and result "dense" -> go via "general"
204              data <- as(data, "triangularMatrix")              ctype <- typeof(data)
205          else if(isSym && !is(data, "symmetricMatrix"))              if (ctype == "complex")
206              data <- as(data, "symmetricMatrix")                  stop("complex matrices not yet implemented in Matrix package")
207                if (ctype == "integer") ## integer Matrices not yet implemented
208                    storage.mode(data) <- "double"
209                data <- new(paste(.M.kind(data), "geMatrix", sep=''),
210                            Dim = dim(data),
211                            Dimnames = .M.DN(data),
212                            x = c(data))
213            }
214      }      }
215      ## now coerce in any case .. maybe producing sensible error message:  
216      as(data, cl)      if(isTri && !is(data, "triangularMatrix")) {
217            data <- if(attr(isTri,"kind") == "L") tril(data) else triu(data)
218                                            #was as(data, "triangularMatrix")
219        } else if(isSym && !is(data, "symmetricMatrix"))
220            data <- forceSymmetric(data) #was as(data, "symmetricMatrix")
221    
222        data
223  }  }
224    
225  ## Methods for operations where one argument is numeric  ## Methods for operations where one argument is numeric
# Line 298  Line 311 
311                Y <- as(Y, "matrix") ; Matrix(callGeneric()) })                Y <- as(Y, "matrix") ; Matrix(callGeneric()) })
312    
313    
314    setMethod("determinant", signature(x = "Matrix", logarithm = "missing"),
315              function(x, logarithm, ...)
316              determinant(x, logarithm = TRUE, ...))
317    
318    if(FALSE) { ## This is desired "in theory" - but gives
319        ## "The following object(s) are masked from package:base :   det
320    ## base::det() calls [base::]determinant();
321    ## our det() should call our determinant() :
322    det <- base::det
323    environment(det) <- environment()## == as.environment("Matrix")
324    }
325    
326  ## FIXME: All of these should never be called  ## FIXME: All of these should never be called
327  setMethod("chol", signature(x = "Matrix"),  setMethod("chol", signature(x = "Matrix"),
328            function(x, pivot = FALSE) .bail.out.1(.Generic, class(x)))            function(x, pivot, ...) .bail.out.1(.Generic, class(x)))
329  setMethod("determinant", signature(x = "Matrix"),  setMethod("determinant", signature(x = "Matrix", logarithm = "logical"),
330            function(x, logarithm = TRUE) .bail.out.1(.Generic, class(x)))            function(x, logarithm, ...)
331              determinant(as(x,"dMatrix"), logarithm=logarithm, ...))
332    
333  setMethod("diag", signature(x = "Matrix"),  setMethod("diag", signature(x = "Matrix"),
334            function(x, nrow, ncol) .bail.out.1(.Generic, class(x)))            function(x, nrow, ncol) .bail.out.1(.Generic, class(x)))
# Line 311  Line 337 
337    
338  setMethod("norm", signature(x = "Matrix", type = "character"),  setMethod("norm", signature(x = "Matrix", type = "character"),
339            function(x, type, ...) .bail.out.1(.Generic, class(x)))            function(x, type, ...) .bail.out.1(.Generic, class(x)))
340  setMethod("rcond", signature(x = "Matrix", type = "character"),  setMethod("rcond", signature(x = "Matrix", norm = "character"),
341            function(x, type, ...) .bail.out.1(.Generic, class(x)))            function(x, norm, ...) .bail.out.1(.Generic, class(x)))
342    
343    
344  ## for all :  ## for all :
345  setMethod("norm", signature(x = "ANY", type = "missing"),  setMethod("norm", signature(x = "ANY", type = "missing"),
346            function(x, type, ...) norm(x, type = "O", ...))            function(x, type, ...) norm(x, type = "O", ...))
347  setMethod("rcond", signature(x = "ANY", type = "missing"),  setMethod("rcond", signature(x = "ANY", norm = "missing"),
348            function(x, type, ...) rcond(x, type = "O", ...))            function(x, norm, ...) rcond(x, norm = "O", ...))
349    
350    
351    
# Line 353  Line 379 
379    
380  ## Group Methods  ## Group Methods
381    
 ##-> see ./Ops.R  
 ##         ~~~~~  
382  ## For all  non-dMatrix objects, and note that  "all" and "any" have their own  ## For all  non-dMatrix objects, and note that  "all" and "any" have their own
383  setMethod("Summary", signature(x = "Matrix", na.rm = "ANY"),  setMethod("Summary", signature(x = "Matrix", na.rm = "ANY"),
384            function(x, ..., na.rm)            function(x, ..., na.rm)
385            callGeneric(as(x,"dMatrix"), ..., na.rm = na.rm))            callGeneric(as(x,"dMatrix"), ..., na.rm = na.rm))
386    
387    Summary.l <- function(x, ..., na.rm) { ## must be method directly
388        r <- callGeneric(as(x,"dMatrix"), ..., na.rm = na.rm)
389        if(!is.infinite(r) && .Generic %in% c("max", "min", "range", "sum"))
390            as.integer(r) else r
391    }
392    setMethod("Summary", signature(x = "lMatrix", na.rm = "ANY"), Summary.l)
393    setMethod("Summary", signature(x = "nMatrix", na.rm = "ANY"), Summary.l)
394    setMethod("Summary", signature(x = "pMatrix", na.rm = "ANY"), Summary.l)
395    
396    ## Further, see ./Ops.R
397    ##                ~~~~~
398    
399    
400  ### --------------------------------------------------------------------------  ### --------------------------------------------------------------------------
401  ###  ###
# Line 376  Line 412 
412    
413  ## missing 'drop' --> 'drop = TRUE'  ## missing 'drop' --> 'drop = TRUE'
414  ##                     -----------  ##                     -----------
415  ## select rows  ## select rows __ or __ vector indexing:
416  setMethod("[", signature(x = "Matrix", i = "index", j = "missing",  setMethod("[", signature(x = "Matrix", i = "index", j = "missing",
417                           drop = "missing"),                           drop = "missing"),
418            function(x,i,j, ..., drop) {            function(x,i,j, ..., drop) {
419                if(nargs() == 2) { ## e.g. M[0] , M[TRUE],  M[1:2]                if(nargs() == 2) { ## e.g. M[0] , M[TRUE],  M[1:2]
420                    if(any(i) || prod(dim(x)) == 0)                    if(any(as.logical(i)) || prod(dim(x)) == 0)
421                          ## FIXME: for *large sparse*, use sparseVector !
422                        as.vector(x)[i]                        as.vector(x)[i]
423                    else ## save memory                    else ## save memory (for large sparse M):
424                        as.vector(x[1,1])[FALSE]                        as.vector(x[1,1])[FALSE]
425                } else {                } else {
426                    callGeneric(x, i=i, , drop=TRUE)                    callGeneric(x, i=i, , drop=TRUE)
# Line 412  Line 449 
449      nA <- nargs()      nA <- nargs()
450      if(nA == 2) { ##  M [ M >= 7 ]      if(nA == 2) { ##  M [ M >= 7 ]
451          ## FIXME: when both 'x' and 'i' are sparse, this can be very inefficient          ## FIXME: when both 'x' and 'i' are sparse, this can be very inefficient
452          as(x, geClass(x))@x[as.vector(i)]          if(is(x, "sparseMatrix"))
453                message("<sparse>[ <logic> ] : .M.sub.i.logical() maybe inefficient")
454            toC <- geClass(x)
455            if(canCoerce(x, toC)) as(x, toC)@x[as.vector(i)]
456            else as(as(as(x, "generalMatrix"), "denseMatrix"), toC)@x[as.vector(i)]
457          ## -> error when lengths don't match          ## -> error when lengths don't match
458      } else if(nA == 3) { ##  M [ M[,1, drop=FALSE] >= 7, ]      } else if(nA == 3) { ##  M [ M[,1, drop=FALSE] >= 7, ]
459          stop("not-yet-implemented 'Matrix' subsetting") ## FIXME          stop("not-yet-implemented 'Matrix' subsetting") ## FIXME
# Line 428  Line 469 
469            .M.sub.i.logical)            .M.sub.i.logical)
470    
471    
472    subset.ij <- function(x, ij) {
473        m <- nrow(ij)
474        if(m > 3) {
475            cld <- getClassDef(class(x))
476            sym.x <- extends(cld, "symmetricMatrix")
477            if(sym.x) {
478                W <- if(x@uplo == "U") # stored only [i,j] with i <= j
479                    ij[,1] > ij[,2] else ij[,1] < ij[,2]
480                if(any(W))
481                    ij[W,] <- ij[W, 2:1]
482            }
483            if(extends(cld, "sparseMatrix")) {
484                ## do something smarter:
485                nr <- nrow(x)
486                if(!extends(cld, "CsparseMatrix")) {
487                    x <- as(x, "CsparseMatrix") # simpler; our standard
488                    cld <- getClassDef(class(x))
489                }
490                tri.x <- extends(cld, "triangularMatrix")
491                if(tri.x) {
492                    ## need these for the 'x' slot in any case
493                    if (x@diag == "U") x <- .Call(Csparse_diagU2N, x)
494                    ## slightly more efficient than non0.i() or non0ind():
495                    ij.x <- .Call(compressed_non_0_ij, x, isC=TRUE)
496                } else { ## symmetric / general : for symmetric, only "existing"b
497                    ij.x <- non0.i(x, cld)
498                }
499    
500                mi <- match(encodeInd(ij.x,   nr),
501                            encodeInd(ij -1L, nr), nomatch=0)
502                mmi <- mi != 0
503                ## Result:
504                ans <- vector(mode = .type.kind[.M.kindC(cld)], length = m)
505                ## those that are *not* zero:
506                ans[mi[mmi]] <-
507                    if(extends(cld, "nsparseMatrix")) TRUE else x@x[mmi]
508                ans
509    
510            } else { ## non-sparse : dense
511                ##---- NEVER happens:  'denseMatrix' has its own setMethod(.) !
512                message("m[ <ij-matrix> ]: inefficiently indexing single elements")
513                i1 <- ij[,1]
514                i2 <- ij[,2]
515                ## very inefficient for large m
516                unlist(lapply(seq_len(m), function(j) x[i1[j], i2[j]]))
517            }
518        } else { # 1 <= m <= 3
519            i1 <- ij[,1]
520            i2 <- ij[,2]
521            unlist(lapply(seq_len(m), function(j) x[i1[j], i2[j]]))
522        }
523    }
524    
525  ## A[ ij ]  where ij is (i,j) 2-column matrix -- but also when that is logical mat!  ## A[ ij ]  where ij is (i,j) 2-column matrix -- but also when that is logical mat!
526  .M.sub.i.2col <- function (x, i, j, ..., drop)  .M.sub.i.2col <- function (x, i, j, ..., drop)
527  {  {
# Line 443  Line 537 
537          m <- nrow(i)          m <- nrow(i)
538          if(m == 0) return(vector(mode = .type.kind[.M.kind(x)]))          if(m == 0) return(vector(mode = .type.kind[.M.kind(x)]))
539          ## else          ## else
540          i1 <- i[,1]          subset.ij(x, i)
         i2 <- i[,2]  
         ## potentially inefficient -- FIXME --  
         unlist(lapply(seq_len(m), function(j) x[i1[j], i2[j]]))  
541    
542      } else stop("nargs() = ", nA,      } else stop("nargs() = ", nA,
543                  ".  Extraneous illegal arguments inside '[ .. ]' (i.2col)?")                  ".  Extraneous illegal arguments inside '[ .. ]' (i.2col)?")
# Line 502  Line 593 
593          value <- rep(value, length = m)          value <- rep(value, length = m)
594          i1 <- i[,1]          i1 <- i[,1]
595          i2 <- i[,2]          i2 <- i[,2]
596            if(m > 2)
597                message("m[ <ij-matrix> ] <- v: inefficiently treating single elements")
598          ## inefficient -- FIXME -- (also loses "symmetry" unnecessarily)          ## inefficient -- FIXME -- (also loses "symmetry" unnecessarily)
599          for(k in seq_len(m))          for(k in seq_len(m))
600              x[i1[k], i2[k]] <- value[k]              x[i1[k], i2[k]] <- value[k]

Legend:
Removed from v.2110  
changed lines
  Added in v.2185

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