SCM Repository

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

[matrix] / pkg / R / Matrix.R

Diff of /pkg/R/Matrix.R

-revision 1455, Mon Aug 28 15:35:44 2006 UTC
+revision 1655, Mon Oct 30 17:16:27 2006 UTC
 Line 6
  setAs("Matrix", "sparseMatrix", function(from) as_Csparse(from))
  setAs("Matrix", "denseMatrix",  function(from) as_dense(from))
+ ## Most of these work; this is a last resort:
+ setAs(from = "Matrix", to = "matrix", # do *not* call base::as.matrix() here:
+       function(from) .bail.out.2("coerce", class(from), class(to)))
+ setAs(from = "matrix", to = "Matrix", function(from) Matrix(from))
  ## ## probably not needed eventually:
  ## setAs(from = "ddenseMatrix", to = "matrix",
  ##       function(from) {
-Line 19
+Line 24
  setMethod("as.array",  signature(x = "Matrix"), function(x) as(x, "matrix"))
  ## head and tail apply to all Matrix objects for which subscripting is allowed:
- ## if(paste(R.version$major, R.version$minor, sep=".") < "2.4") {
+ setMethod("head", signature(x = "Matrix"), utils::head.matrix)
-     setMethod("head", signature(x = "Matrix"), utils:::head.matrix)
+ setMethod("tail", signature(x = "Matrix"), utils::tail.matrix)
-     setMethod("tail", signature(x = "Matrix"), utils:::tail.matrix)
- ## } else { # R 2.4.0 and newer
- ##     setMethod("head", signature(x = "Matrix"), utils::head.matrix)
- ##     setMethod("tail", signature(x = "Matrix"), utils::tail.matrix)
- ## }
  ## slow "fall back" method {subclasses should have faster ones}:
  setMethod("as.vector", signature(x = "Matrix", mode = "missing"),
 Line 38
            function(x, ...) as.logical(as.vector(x)))
- ## Note that isSymmetric is *not* exported
+ ## "base" has an isSymmetric() S3-generic since R 2.3.0
- ## but that "base" has an isSymmetric() S3-generic since R 2.3.0
  setMethod("isSymmetric", signature(object = "symmetricMatrix"),
            function(object,tol) TRUE)
  setMethod("isSymmetric", signature(object = "triangularMatrix"),
            ## TRUE iff diagonal:
            function(object,tol) isDiagonal(object))
- if(paste(R.version$major, R.version$minor, sep=".") < "2.3")
-     ## need a "matrix" method as in R 2.3 and later
-     setMethod("isSymmetric", signature(object = "matrix"),
-               function(object, tol = 100*.Machine$double.eps, ...)
-           {
-               ## pretest: is it square?
-               d <- dim(object)
-               if(d[1] != d[2]) return(FALSE)
-               ## for `broken' all.equal in R <= 2.2.x:
-               dn <- dimnames(object)
-               if(!identical(dn[1], dn[2])) return(FALSE)
-               test <-
-                   if(is.complex(object))
-                       all.equal.numeric(object, Conj(t(object)), tol = tol, ...)
-                   else              # numeric, character, ..
-                       all.equal(object, t(object), tol = tol, ...)
-               isTRUE(test)
-           })
  setMethod("isTriangular", signature(object = "triangularMatrix"),
            function(object, ...) TRUE)
-Line 101
+Line 80
                sparse = NULL, forceCheck = FALSE)
  {
      sparseDefault <- function(m)
-         prod(dim(m)) > 2*sum(as(m, "matrix") != 0)
+         prod(dim(m)) > 2*sum(is.na(m <- as(m, "matrix")) | m != 0)
      i.M <- is(data, "Matrix")
-     if(is.null(sparse) && (i.M || is(data, "matrix")))
+     if(is.null(sparse1 <- sparse) && (i.M || is(data, "matrix")))
          sparse <- sparseDefault(data)
      doDN <- TRUE
-     if (i.M && !forceCheck) {
+     if (i.M) {
          sM <- is(data,"sparseMatrix")
-         if((sparse && sM) || (!sparse && !sM))
+         if(!forceCheck && ((sparse && sM) || (!sparse && !sM)))
              return(data)
          ## else : convert  dense <-> sparse -> at end
      }
-Line 119
+Line 99
              nrow <- ceiling(length(data)/ncol)
          else if (missing(ncol))
              ncol <- ceiling(length(data)/nrow)
-         if(length(data) == 1 && data == 0 && !identical(sparse,FALSE)) {
+         if(length(data) == 1 && is0(data) && !identical(sparse, FALSE)) {
-             if(is.null(sparse)) sparse <- TRUE
+             ## Matrix(0, ...) : always sparse unless "sparse = FALSE":
+             if(is.null(sparse)) sparse1 <- sparse <- TRUE
              ## will be sparse: do NOT construct full matrix!
              data <- new(if(is.numeric(data)) "dgTMatrix" else
                          if(is.logical(data)) "lgTMatrix" else
-Line 148
+Line 129
      if(isDiag)
          isDiag <- isDiagonal(data)
- ### TODO: Compare with as.Matrix() and its tests in ./dgeMatrix.R
      ## Find proper matrix class 'cl'
      cl <-
-         if(isDiag)
+         if(isDiag && !isTRUE(sparse1))
              "diagonalMatrix" # -> will automatically check for type
          else {
              ## consider it's type
-Line 242
+Line 221
                Y <- as(Y, "matrix") ; Matrix(callGeneric()) })
+ ## FIXME: All of these should never be called
+ setMethod("chol", signature(x = "Matrix"),
+           function(x, pivot = FALSE) .bail.out.1(.Generic, class(x)))
+ setMethod("determinant", signature(x = "Matrix"),
+           function(x, logarithm = TRUE) .bail.out.1(.Generic, class(x)))
  setMethod("diag", signature(x = "Matrix"),
            function(x, nrow, ncol) .bail.out.1(.Generic, class(x)))
  setMethod("t", signature(x = "Matrix"),
-Line 256
+Line 241
 -e1
            })
- ## bail-outs:
+ ## old-style matrices are made into new ones
- setMethod("Compare", signature(e1 = "Matrix", e2 = "Matrix"),
+ setMethod("Ops", signature(e1 = "Matrix", e2 = "matrix"),
+           function(e1, e2) callGeneric(e1, Matrix(e2)))
+ ##          callGeneric(e1, Matrix(e2, sparse=is(e1,"sparseMatrix"))))
+ setMethod("Ops", signature(e1 = "matrix", e2 = "Matrix"),
+           function(e1, e2) callGeneric(Matrix(e1), e2))
+ ## bail-outs -- on highest possible level, hence "Ops", not "Compare"/"Arith" :
+ setMethod("Ops", signature(e1 = "Matrix", e2 = "Matrix"),
            function(e1, e2) {
                d <- dimCheck(e1,e2)
                .bail.out.2(.Generic, class(e1), class(e2))
            })
- setMethod("Compare", signature(e1 = "Matrix", e2 = "ANY"),
+ setMethod("Ops", signature(e1 = "Matrix", e2 = "ANY"),
            function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
- setMethod("Compare", signature(e1 = "ANY", e2 = "Matrix"),
+ setMethod("Ops", signature(e1 = "ANY", e2 = "Matrix"),
            function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
-Line 301
+Line 293
            function(x,i,j, drop)
            stop("invalid or not-yet-implemented 'Matrix' subsetting"))
- ##  "logical *vector* indexing, such as  M [ M >= 10 ] :
+ ## logical indexing, such as M[ M >= 7 ] *BUT* also M[ M[,1] >= 3,],
- setMethod("[", signature(x = "Matrix", i = "lMatrix", j = "missing",
+ ## The following is *both* for    M [ <logical>   ]
-                          drop = "ANY"),
+ ##                 and also for   M [ <logical> , ]
-           function (x, i, j, drop) {
+ .M.sub.i.logical <- function (x, i, j, drop)
+ {
+     nA <- nargs()
+     if(nA == 2) { ##  M [ M >= 7 ]
                as(x, geClass(x))@x[as.vector(i)]
                ## -> error when lengths don't match
-           })
+     } else if(nA == 3) { ##  M [ M[,1, drop=FALSE] >= 7, ]
+         stop("not-yet-implemented 'Matrix' subsetting") ## FIXME
- ## FIXME: The following is good for    M [ <logical>   ]
+     } else stop("nargs() = ", nA,
- ##        *BUT* it also triggers for   M [ <logical> , ] where it is *WRONG*
+                 " should never happen; please report.")
- ##       using nargs() does not help: it gives '3' for both cases
+ }
- if(FALSE)
+ setMethod("[", signature(x = "Matrix", i = "lMatrix", j = "missing",
+                          drop = "ANY"),
+           .M.sub.i.logical)
  setMethod("[", signature(x = "Matrix", i = "logical", j = "missing",
                           drop = "ANY"),
-           function (x, i, j, drop) {
+           .M.sub.i.logical)
-               ## DEBUG
-               cat("[(Matrix,i,..): nargs=", nargs(),"\n")
-               as(x, geClass(x))@x[i] })
  ## "FIXME:"
- ## How can we get at   A[ ij ]  where ij is (i,j) 2-column matrix?
+ ## ------ get at  A[ ij ]  where ij is (i,j) 2-column matrix?
- ##  and                A[ LL ]  where LL is a logical *vector*
- ## -> [.data.frame uses nargs() - can we do this in the *generic* ?
  ### "[<-" : -----------------
-Line 333
+Line 327
  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
                                  value = "ANY"),## double/logical/...
            function (x, value) {
+               ## Fails for 'nMatrix' ... FIXME : make sure have method there
                x@x <- value
                validObject(x)# check if type and lengths above match
                x
            })
- ## Method for all 'Matrix' kinds (rather than incomprehensible error messages);
+ setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
+                                 value = "Matrix"),
+                  function (x, i, j, value)
+                  callGeneric(x=x, i=i, j=j, value = as.vector(value)))
+ setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
+                                 value = "matrix"),
+                  function (x, i, j, value)
+                  callGeneric(x=x, i=i, j=j, value = c(value)))
  ## (ANY,ANY,ANY) is used when no `real method' is implemented :
  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
                                  value = "ANY"),
            function (x, i, j, value) {
                if(!is.atomic(value))
-                   stop("RHS 'value' must match matrix class ", class(x))
+                   stop(sprintf("RHS 'value' (class %s) matches 'ANY', but must match matrix class %s",
+                                class(value),class(x)))
                else stop("not-yet-implemented 'Matrix[<-' method")
            })

 Legend:



Removed from v.1455
 


changed lines


 
Added in v.1655
 Legend:



Removed from v.1455
 


changed lines


 
Added in v.1655
-Removed from v.1455
+Added in v.1655

root@r-forge.r-project.org	ViewVC Help
Powered by ViewVC 1.0.0