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 965, Wed Oct 5 16:57:55 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    setMethod("isSymmetric", signature(object = "symmetricMatrix"),
22              function(object) TRUE)
23    setMethod("isSymmetric", signature(object = "triangularMatrix"),
24              ## FIXME: 'TRUE' if *diagonal*, i.e. return(isDiagonal(object))
25              function(object) FALSE)
26    setMethod("isDiagonal", signature(object = "sparseMatrix"),
27              function(object) {
28                  gT <- as(object, "TsparseMatrix")
29                  all(gT@i == gT@j)
30              })
31    
32  setMethod("dim", signature(x = "Matrix"),  setMethod("dim", signature(x = "Matrix"),
33            function(x) x@Dim, valueClass = "integer")            function(x) x@Dim, valueClass = "integer")
# Line 62  Line 51 
51            function(obj) { obj@Dimnames <- list(NULL,NULL); obj})            function(obj) { obj@Dimnames <- list(NULL,NULL); obj})
52    
53  Matrix <-  Matrix <-
54      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL,
55                  sparse = NULL)
56  {  {
57      if (is(data, "Matrix")) return(data)      sparseDefault <- function(m)
58      if (is.matrix(data)) { val <- data }          prod(dim(m)) > 2*sum(as(m, "matrix") != 0)
59      else { ## cut & paste from "base::matrix" :  
60        i.M <- is(data, "Matrix")
61        if(is.null(sparse) && (i.M || is(data, "matrix")))
62            sparse <- sparseDefault(data)
63    
64        if (i.M) {
65            sM <- is(data,"sparseMatrix")
66            if((sparse && sM) || (!sparse && !sM))
67                return(data)
68            ## else : convert  dense <-> sparse -> at end
69        }
70        else if (!is.matrix(data)) { ## cut & paste from "base::matrix" :
71          if (missing(nrow))          if (missing(nrow))
72              nrow <- ceiling(length(data)/ncol)              nrow <- ceiling(length(data)/ncol)
73          else if (missing(ncol))          else if (missing(ncol))
74              ncol <- ceiling(length(data)/nrow)              ncol <- ceiling(length(data)/nrow)
75          val <- .Internal(matrix(data, nrow, ncol, byrow))          data <- .Internal(matrix(data, nrow, ncol, byrow))
76          dimnames(val) <- dimnames          if(is.null(sparse))
77                sparse <- sparseDefault(data)
78            dimnames(data) <- dimnames
79      }      }
80      as(val, "dgeMatrix")  
81        ## 'data' is now a "matrix" or "Matrix"
82        ## FIXME: consider it's type (logical,....)
83        ## ctype <- substr(class(data), 1,1) # "d", "l", ...
84        ## FIXME(2): check for symmetric / triangular / ...
85    ### TODO: Compare with as.Matrix() and its tests in ./dgeMatrix.R
86        if(sparse)
87            as(data, "dgCMatrix")
88        else
89            as(data, "dgeMatrix")
90  }  }
91    
92  ## Methods for operations where one argument is numeric  ## Methods for operations where one argument is numeric
# Line 97  Line 109 
109  setMethod("solve", signature(a = "Matrix", b = "numeric"),  setMethod("solve", signature(a = "Matrix", b = "numeric"),
110            function(a, b, ...) callGeneric(a, as.matrix(b)))            function(a, b, ...) callGeneric(a, as.matrix(b)))
111    
112    ## bail-out methods in order to get better error messages
113    setMethod("%*%", signature(x = "Matrix", y = "Matrix"),
114              function (x, y)
115              stop(gettextf('not-yet-implemented method for <%s> %%*%% <%s>',
116                            class(x), class(y))))
117    
118    setMethod("crossprod", signature(x = "Matrix", y = "ANY"),
119              function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y)))
120    setMethod("crossprod", signature(x = "ANY", y = "Matrix"),
121              function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y)))
122    
123    ## There are special sparse methods; this is a "fall back":
124    setMethod("kronecker", signature(X = "Matrix", Y = "ANY",
125                                     FUN = "ANY", make.dimnames = "ANY"),
126              function(X, Y, FUN, make.dimnames, ...) {
127                  X <- as(X, "matrix") ; Matrix(callGeneric()) })
128    setMethod("kronecker", signature(X = "ANY", Y = "Matrix",
129                                     FUN = "ANY", make.dimnames = "ANY"),
130              function(X, Y, FUN, make.dimnames, ...) {
131                  Y <- as(Y, "matrix") ; Matrix(callGeneric()) })
132    
133    
134    setMethod("t", signature(x = "Matrix"),
135              function(x) .bail.out.1(.Generic, class(x)))
136    
137    ## Group Methods
138    setMethod("+", signature(e1 = "Matrix", e2 = "missing"), function(e1) e1)
139    ## "fallback":
140    setMethod("-", signature(e1 = "Matrix", e2 = "missing"),
141              function(e1) {
142                  warning("inefficient method used for \"- e1\"")
143                  0-e1
144              })
145    
146    ## bail-outs:
147    setMethod("Compare", signature(e1 = "Matrix", e2 = "Matrix"),
148              function(e1, e2) {
149                  d <- dimCheck(e1,e2)
150                  .bail.out.2(.Generic, class(e1), class(e2))
151              })
152    setMethod("Compare", signature(e1 = "Matrix", e2 = "ANY"),
153              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
154    setMethod("Compare", signature(e1 = "ANY", e2 = "Matrix"),
155              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
156    
157    
158    
159  ### --------------------------------------------------------------------------  ### --------------------------------------------------------------------------
160  ###  ###
161  ### Subsetting "["  and  ### Subsetting "["  and
162  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":
163    
164    ## Using "index" for indices should allow
165    ## integer (numeric), logical, or character (names!) indices :
166    
167  ## "x[]":  ## "x[]":
168  setMethod("[", signature(x = "Matrix",  setMethod("[", signature(x = "Matrix",
169                           i = "missing", j = "missing", drop = "ANY"),                           i = "missing", j = "missing", drop = "ANY"),
# Line 109  Line 171 
171  ## missing 'drop' --> 'drop = TRUE'  ## missing 'drop' --> 'drop = TRUE'
172  ##                     -----------  ##                     -----------
173  ## select rows  ## select rows
174  setMethod("[", signature(x = "Matrix", i = "numeric", j = "missing",  setMethod("[", signature(x = "Matrix", i = "index", j = "missing",
175                           drop = "missing"),                           drop = "missing"),
176            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))
177  ## select columns  ## select columns
178  setMethod("[", signature(x = "Matrix", i = "missing", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "missing", j = "index",
179                           drop = "missing"),                           drop = "missing"),
180            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))
181  setMethod("[", signature(x = "Matrix", i = "numeric", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "index", j = "index",
182                           drop = "missing"),                           drop = "missing"),
183            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))
184    
185    ## bail out if any of (i,j,drop) is "non-sense"
186    setMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", drop = "ANY"),
187              function(x,i,j, drop)
188              stop("invalid or not-yet-implemented 'Matrix' subsetting"))
189    
190  ## "FIXME:"  ## "FIXME:"
191  ## 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?
192  ##  and                A[ LL ]  where LL is a logical *vector*  ##  and                A[ LL ]  where LL is a logical *vector*
193    ## -> [.data.frame uses nargs() - can we do this in the *generic* ?
194    
195    
196  ### "[<-" : -----------------  ### "[<-" : -----------------
197    
198  ## x[] <- value :  ## x[] <- value :
199  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
200                                  value = "vector"),##  double/logical/...                                  value = "index"),##  double/logical/...
201            function (x, value) { x@x <- value ; validObject(x); x })            function (x, value) { x@x <- value ; validObject(x); x })
202    
203  ## Otherwise (value is not "vector"): bail out  ## Otherwise (value is not "index"): bail out
204  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
205                                  value = "ANY"),                                  value = "ANY"),
206            function (x, i, j, value) stop("RHS 'value' must be of class \"vector\""))            function (x, i, j, value)
207                     if(!is(value,"index"))
208                     stop("RHS 'value' must be of class \"index\"")
209                     else stop("not-yet-implemented 'Matrix[<-' method"))
210    
211    
212    
213  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) ---
214  setMethod("cbind", signature(a = "Matrix", b = "Matrix"),  ## ----  *and* 'Matrix' must have been *installed* by R >= 2.2.x
215            function(a, b, ...) {  
216                da <- Dim(a)  if(paste(R.version$major, R.version$minor, sep=".") >= "2.2") {
217                db <- Dim(b)  
218                if(da[1] != db[1])      ## The trivial methods :
219                    stop("Matrices must have same number of rows for cbind()ing")      setMethod("cbind2", signature(x = "Matrix", y = "NULL"),
220                  function(x, y) x)
221        setMethod("cbind2", signature(x = "Matrix", y = "missing"),
222                  function(x, y) x)
223        setMethod("cbind2", signature(x = "NULL", y="Matrix"),
224                  function(x, y) x)
225    
226        setMethod("rbind2", signature(x = "Matrix", y = "NULL"),
227                  function(x, y) x)
228        setMethod("rbind2", signature(x = "Matrix", y = "missing"),
229                  function(x, y) x)
230        setMethod("rbind2", signature(x = "NULL", y="Matrix"),
231                  function(x, y) x)
232    
233        ## Makes sure one gets x decent error message for the unimplemented cases:
234        setMethod("cbind2", signature(x = "Matrix", y = "Matrix"),
235                  function(x, y) {
236                      rowCheck(x,y)
237                      stop(gettextf("cbind2() method for (%s,%s) not-yet defined",
238                                    class(x), class(y)))
239            })            })
240    
241        ## Use a working fall back {particularly useful for sparse}:
242        ## FIXME: implement rbind2 via "cholmod" for C* and Tsparse ones
243        setMethod("rbind2", signature(x = "Matrix", y = "Matrix"),
244                  function(x, y) {
245                      colCheck(x,y)
246                      t(cbind2(t(x), t(y)))
247                  })
248    
249    }## R-2.2.x and newer

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

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