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 871, Fri Aug 26 17:26:49 2005 UTC revision 973, Fri Oct 7 20:15:08 2005 UTC
# Line 1  Line 1 
1  #### Toplevel ``virtual'' class "Matrix"  #### Toplevel ``virtual'' class "Matrix"
2    
3  ## probably not needed eventually:  ## ## probably not needed eventually:
4  setAs(from = "ddenseMatrix", to = "matrix",  ## setAs(from = "ddenseMatrix", to = "matrix",
5        function(from) {  ##       function(from) {
6            if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")  ##        if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")
7            array(from@x, dim = d, dimnames = dimnames(from))  ##        array(from@x, dim = d, dimnames = dimnames(from))
8        })  ##       })
   
 ## private function to be used as show() method possibly more than once  
 prMatrix <- function(object) {  
     d <- dim(object)  
     cl <- class(object)  
     cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))  
     m <- as(object, "matrix")  
     maxp <- getOption("max.print")  
     if(prod(d) <= maxp) print(m)  
     else { ## d[1] > maxp / d[2] >= nr :  
         nr <- maxp %/% d[2]  
         n2 <- ceiling(nr / 2)  
         print(head(m, max(1, n2)))  
         cat("\n ..........\n\n")  
         print(tail(m, max(1, nr - n2)))  
     }  
     ## DEBUG: cat("str(.):\n") ; str(object)  
     invisible(object)# as print() S3 methods do  
 }  
   
 setMethod("show", signature(object = "ddenseMatrix"), prMatrix)  
   
 ##- ## FIXME: The following is only for the "dMatrix" objects that are not  
 ##- ##        "dense" nor "sparse" -- i.e. "packed" ones :  
 ##- ## But these could be printed better -- "." for structural zeros.  
 ##- setMethod("show", signature(object = "dMatrix"), prMatrix)  
 ##- ## and improve this as well:  
 ##- setMethod("show", signature(object = "pMatrix"), prMatrix)  
 ##- ## this should now be superfluous [keep for safety for the moment]:  
 setMethod("show", signature(object = "Matrix"), prMatrix)  
9    
10  ## should propagate to all subclasses:  ## should propagate to all subclasses:
11  setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))  setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))
12    ## for 'Matrix' objects, as.array() should be equivalent:
13    setMethod("as.array",  signature(x = "Matrix"), function(x) as(x, "matrix"))
14    
15    ## slow "fall back" method {subclasses should have faster ones}:
16    setMethod("as.vector", signature(x = "Matrix", mode = "missing"),
17              function(x) as.vector(as(x, "matrix")))
18    
19    
20    ## Note that isSymmetric is *not* exported ---
21    ### but also note that "base" eigen may get an isSymmetric() that *would* be exported!
22    setMethod("isSymmetric", signature(object = "symmetricMatrix", tol="ANY"),
23              function(object,tol) TRUE)
24    setMethod("isSymmetric", signature(object = "triangularMatrix", tol="ANY"),
25              ## FIXME: 'TRUE' if *diagonal*, i.e. return(isDiagonal(object))
26              function(object,tol) FALSE)
27    
28    setMethod("isDiagonal", signature(object = "sparseMatrix"),
29              function(object) {
30                  gT <- as(object, "TsparseMatrix")
31                  all(gT@i == gT@j)
32              })
33    
34  setMethod("dim", signature(x = "Matrix"),  setMethod("dim", signature(x = "Matrix"),
35            function(x) x@Dim, valueClass = "integer")            function(x) x@Dim, valueClass = "integer")
# Line 62  Line 53 
53            function(obj) { obj@Dimnames <- list(NULL,NULL); obj})            function(obj) { obj@Dimnames <- list(NULL,NULL); obj})
54    
55  Matrix <-  Matrix <-
56      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL,
57                  sparse = NULL)
58  {  {
59      if (is(data, "Matrix")) return(data)      sparseDefault <- function(m)
60      if (is.matrix(data)) { val <- data }          prod(dim(m)) > 2*sum(as(m, "matrix") != 0)
61      else { ## cut & paste from "base::matrix" :  
62        i.M <- is(data, "Matrix")
63        if(is.null(sparse) && (i.M || is(data, "matrix")))
64            sparse <- sparseDefault(data)
65    
66        if (i.M) {
67            sM <- is(data,"sparseMatrix")
68            if((sparse && sM) || (!sparse && !sM))
69                return(data)
70            ## else : convert  dense <-> sparse -> at end
71        }
72        else if (!is.matrix(data)) { ## cut & paste from "base::matrix" :
73          if (missing(nrow))          if (missing(nrow))
74              nrow <- ceiling(length(data)/ncol)              nrow <- ceiling(length(data)/ncol)
75          else if (missing(ncol))          else if (missing(ncol))
76              ncol <- ceiling(length(data)/nrow)              ncol <- ceiling(length(data)/nrow)
77          val <- .Internal(matrix(data, nrow, ncol, byrow))          data <- .Internal(matrix(data, nrow, ncol, byrow))
78          dimnames(val) <- dimnames          if(is.null(sparse))
79                sparse <- sparseDefault(data)
80            dimnames(data) <- dimnames
81      }      }
82      as(val, "dgeMatrix")  
83        ## 'data' is now a "matrix" or "Matrix"
84        ## FIXME: consider it's type (logical,....)
85        ## ctype <- substr(class(data), 1,1) # "d", "l", ...
86        ## FIXME(2): check for symmetric / triangular / ...
87    ### TODO: Compare with as.Matrix() and its tests in ./dgeMatrix.R
88        if(sparse)
89            as(data, "dgCMatrix")
90        else
91            as(data, "dgeMatrix")
92  }  }
93    
94  ## Methods for operations where one argument is numeric  ## Methods for operations where one argument is numeric
# Line 97  Line 111 
111  setMethod("solve", signature(a = "Matrix", b = "numeric"),  setMethod("solve", signature(a = "Matrix", b = "numeric"),
112            function(a, b, ...) callGeneric(a, as.matrix(b)))            function(a, b, ...) callGeneric(a, as.matrix(b)))
113    
114    ## bail-out methods in order to get better error messages
115    setMethod("%*%", signature(x = "Matrix", y = "Matrix"),
116              function (x, y)
117              stop(gettextf('not-yet-implemented method for <%s> %%*%% <%s>',
118                            class(x), class(y))))
119    
120    setMethod("crossprod", signature(x = "Matrix", y = "ANY"),
121              function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y)))
122    setMethod("crossprod", signature(x = "ANY", y = "Matrix"),
123              function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y)))
124    
125    ## There are special sparse methods; this is a "fall back":
126    setMethod("kronecker", signature(X = "Matrix", Y = "ANY",
127                                     FUN = "ANY", make.dimnames = "ANY"),
128              function(X, Y, FUN, make.dimnames, ...) {
129                  X <- as(X, "matrix") ; Matrix(callGeneric()) })
130    setMethod("kronecker", signature(X = "ANY", Y = "Matrix",
131                                     FUN = "ANY", make.dimnames = "ANY"),
132              function(X, Y, FUN, make.dimnames, ...) {
133                  Y <- as(Y, "matrix") ; Matrix(callGeneric()) })
134    
135    
136    setMethod("t", signature(x = "Matrix"),
137              function(x) .bail.out.1(.Generic, class(x)))
138    
139    ## Group Methods
140    setMethod("+", signature(e1 = "Matrix", e2 = "missing"), function(e1) e1)
141    ## "fallback":
142    setMethod("-", signature(e1 = "Matrix", e2 = "missing"),
143              function(e1) {
144                  warning("inefficient method used for \"- e1\"")
145                  0-e1
146              })
147    
148    ## bail-outs:
149    setMethod("Compare", signature(e1 = "Matrix", e2 = "Matrix"),
150              function(e1, e2) {
151                  d <- dimCheck(e1,e2)
152                  .bail.out.2(.Generic, class(e1), class(e2))
153              })
154    setMethod("Compare", signature(e1 = "Matrix", e2 = "ANY"),
155              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
156    setMethod("Compare", signature(e1 = "ANY", e2 = "Matrix"),
157              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
158    
159    
160    
161  ### --------------------------------------------------------------------------  ### --------------------------------------------------------------------------
162  ###  ###
163  ### Subsetting "["  and  ### Subsetting "["  and
164  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":
165    
166    ## Using "index" for indices should allow
167    ## integer (numeric), logical, or character (names!) indices :
168    
169  ## "x[]":  ## "x[]":
170  setMethod("[", signature(x = "Matrix",  setMethod("[", signature(x = "Matrix",
171                           i = "missing", j = "missing", drop = "ANY"),                           i = "missing", j = "missing", drop = "ANY"),
# Line 109  Line 173 
173  ## missing 'drop' --> 'drop = TRUE'  ## missing 'drop' --> 'drop = TRUE'
174  ##                     -----------  ##                     -----------
175  ## select rows  ## select rows
176  setMethod("[", signature(x = "Matrix", i = "numeric", j = "missing",  setMethod("[", signature(x = "Matrix", i = "index", j = "missing",
177                           drop = "missing"),                           drop = "missing"),
178            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))
179  ## select columns  ## select columns
180  setMethod("[", signature(x = "Matrix", i = "missing", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "missing", j = "index",
181                           drop = "missing"),                           drop = "missing"),
182            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))
183  setMethod("[", signature(x = "Matrix", i = "numeric", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "index", j = "index",
184                           drop = "missing"),                           drop = "missing"),
185            function(x,i,j, drop) callGeneric(x, i=i, j=j, drop= TRUE))            function(x,i,j, drop) callGeneric(x, i=i, j=j, drop= TRUE))
186    
187    ## bail out if any of (i,j,drop) is "non-sense"
188    setMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", drop = "ANY"),
189              function(x,i,j, drop)
190              stop("invalid or not-yet-implemented 'Matrix' subsetting"))
191    
192  ## "FIXME:"  ## "FIXME:"
193  ## How can we get at   A[ ij ]  where ij is (i,j) 2-column matrix?  ## How can we get at   A[ ij ]  where ij is (i,j) 2-column matrix?
194  ##  and                A[ LL ]  where LL is a logical *vector*  ##  and                A[ LL ]  where LL is a logical *vector*
195    ## -> [.data.frame uses nargs() - can we do this in the *generic* ?
196    
197    
198  ### "[<-" : -----------------  ### "[<-" : -----------------
199    
200  ## x[] <- value :  ## x[] <- value :
201  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
202                                  value = "vector"),##  double/logical/...                                  value = "index"),##  double/logical/...
203            function (x, value) { x@x <- value ; validObject(x); x })            function (x, value) { x@x <- value ; validObject(x); x })
204    
205  ## Otherwise (value is not "vector"): bail out  ## Otherwise (value is not "index"): bail out
206  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
207                                  value = "ANY"),                                  value = "ANY"),
208            function (x, i, j, value) stop("RHS 'value' must be of class \"vector\""))            function (x, i, j, value)
209                     if(!is(value,"index"))
210                     stop("RHS 'value' must be of class \"index\"")
211                     else stop("not-yet-implemented 'Matrix[<-' method"))
212    
213    
214    
215  if(FALSE) ## The following can't work as long as cbind is function(..., *)  ## NOTE: the following only works for R 2.2.x (and later) ---
216  setMethod("cbind", signature(a = "Matrix", b = "Matrix"),  ## ----  *and* 'Matrix' must have been *installed* by R >= 2.2.x
217            function(a, b, ...) {  
218                da <- Dim(a)  if(paste(R.version$major, R.version$minor, sep=".") >= "2.2") {
219                db <- Dim(b)  
220                if(da[1] != db[1])      ## The trivial methods :
221                    stop("Matrices must have same number of rows for cbind()ing")      setMethod("cbind2", signature(x = "Matrix", y = "NULL"),
222                  function(x, y) x)
223        setMethod("cbind2", signature(x = "Matrix", y = "missing"),
224                  function(x, y) x)
225        setMethod("cbind2", signature(x = "NULL", y="Matrix"),
226                  function(x, y) x)
227    
228        setMethod("rbind2", signature(x = "Matrix", y = "NULL"),
229                  function(x, y) x)
230        setMethod("rbind2", signature(x = "Matrix", y = "missing"),
231                  function(x, y) x)
232        setMethod("rbind2", signature(x = "NULL", y="Matrix"),
233                  function(x, y) x)
234    
235        ## Makes sure one gets x decent error message for the unimplemented cases:
236        setMethod("cbind2", signature(x = "Matrix", y = "Matrix"),
237                  function(x, y) {
238                      rowCheck(x,y)
239                      stop(gettextf("cbind2() method for (%s,%s) not-yet defined",
240                                    class(x), class(y)))
241            })            })
242    
243        ## Use a working fall back {particularly useful for sparse}:
244        ## FIXME: implement rbind2 via "cholmod" for C* and Tsparse ones
245        setMethod("rbind2", signature(x = "Matrix", y = "Matrix"),
246                  function(x, y) {
247                      colCheck(x,y)
248                      t(cbind2(t(x), t(y)))
249                  })
250    
251    }## R-2.2.x and newer

Legend:
Removed from v.871  
changed lines
  Added in v.973

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