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 956, Fri Sep 30 17:28:00 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        if(sparse)
86            as(data, "dgCMatrix")
87        else
88            as(data, "dgeMatrix")
89  }  }
90    
91  ## Methods for operations where one argument is numeric  ## Methods for operations where one argument is numeric
# Line 97  Line 108 
108  setMethod("solve", signature(a = "Matrix", b = "numeric"),  setMethod("solve", signature(a = "Matrix", b = "numeric"),
109            function(a, b, ...) callGeneric(a, as.matrix(b)))            function(a, b, ...) callGeneric(a, as.matrix(b)))
110    
111    ## bail-out methods in order to get better error messages
112    setMethod("%*%", signature(x = "Matrix", y = "Matrix"),
113              function (x, y)
114              stop(gettextf('not-yet-implemented method for <%s> %%*%% <%s>',
115                            class(x), class(y))))
116    
117    setMethod("crossprod", signature(x = "Matrix", y = "ANY"),
118              function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y)))
119    setMethod("crossprod", signature(x = "ANY", y = "Matrix"),
120              function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y)))
121    
122    ## There are special sparse methods; this is a "fall back":
123    setMethod("kronecker", signature(X = "Matrix", Y = "ANY",
124                                     FUN = "ANY", make.dimnames = "ANY"),
125              function(X, Y, FUN, make.dimnames, ...) {
126                  X <- as(X, "matrix") ; Matrix(callGeneric()) })
127    setMethod("kronecker", signature(X = "ANY", Y = "Matrix",
128                                     FUN = "ANY", make.dimnames = "ANY"),
129              function(X, Y, FUN, make.dimnames, ...) {
130                  Y <- as(Y, "matrix") ; Matrix(callGeneric()) })
131    
132    
133    setMethod("t", signature(x = "Matrix"),
134              function(x) .bail.out.1(.Generic, class(x)))
135    
136    ## Group Methods
137    setMethod("+", signature(e1 = "Matrix", e2 = "missing"), function(e1) e1)
138    ## "fallback":
139    setMethod("-", signature(e1 = "Matrix", e2 = "missing"),
140              function(e1) {
141                  warning("inefficient method used for \"- e1\"")
142                  0-e1
143              })
144    
145    ## bail-outs:
146    setMethod("Compare", signature(e1 = "Matrix", e2 = "Matrix"),
147              function(e1, e2) {
148                  d <- dimCheck(e1,e2)
149                  .bail.out.2(.Generic, class(e1), class(e2))
150              })
151    setMethod("Compare", signature(e1 = "Matrix", e2 = "ANY"),
152              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
153    setMethod("Compare", signature(e1 = "ANY", e2 = "Matrix"),
154              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
155    
156    
157    
158  ### --------------------------------------------------------------------------  ### --------------------------------------------------------------------------
159  ###  ###
160  ### Subsetting "["  and  ### Subsetting "["  and
161  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":
162    
163    ## Using "index" for indices should allow
164    ## integer (numeric), logical, or character (names!) indices :
165    
166  ## "x[]":  ## "x[]":
167  setMethod("[", signature(x = "Matrix",  setMethod("[", signature(x = "Matrix",
168                           i = "missing", j = "missing", drop = "ANY"),                           i = "missing", j = "missing", drop = "ANY"),
# Line 109  Line 170 
170  ## missing 'drop' --> 'drop = TRUE'  ## missing 'drop' --> 'drop = TRUE'
171  ##                     -----------  ##                     -----------
172  ## select rows  ## select rows
173  setMethod("[", signature(x = "Matrix", i = "numeric", j = "missing",  setMethod("[", signature(x = "Matrix", i = "index", j = "missing",
174                           drop = "missing"),                           drop = "missing"),
175            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))
176  ## select columns  ## select columns
177  setMethod("[", signature(x = "Matrix", i = "missing", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "missing", j = "index",
178                           drop = "missing"),                           drop = "missing"),
179            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))
180  setMethod("[", signature(x = "Matrix", i = "numeric", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "index", j = "index",
181                           drop = "missing"),                           drop = "missing"),
182            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))
183    
184    ## bail out if any of (i,j,drop) is "non-sense"
185    setMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", drop = "ANY"),
186              function(x,i,j, drop)
187              stop("invalid or not-yet-implemented 'Matrix' subsetting"))
188    
189  ## "FIXME:"  ## "FIXME:"
190  ## 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?
191  ##  and                A[ LL ]  where LL is a logical *vector*  ##  and                A[ LL ]  where LL is a logical *vector*
192    ## -> [.data.frame uses nargs() - can we do this in the *generic* ?
193    
194    
195  ### "[<-" : -----------------  ### "[<-" : -----------------
196    
197  ## x[] <- value :  ## x[] <- value :
198  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
199                                  value = "vector"),##  double/logical/...                                  value = "index"),##  double/logical/...
200            function (x, value) { x@x <- value ; validObject(x); x })            function (x, value) { x@x <- value ; validObject(x); x })
201    
202  ## Otherwise (value is not "vector"): bail out  ## Otherwise (value is not "index"): bail out
203  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
204                                  value = "ANY"),                                  value = "ANY"),
205            function (x, i, j, value) stop("RHS 'value' must be of class \"vector\""))            function (x, i, j, value)
206                     if(!is(value,"index"))
207                     stop("RHS 'value' must be of class \"index\"")
208                     else stop("not-yet-implemented 'Matrix[<-' method"))
209    
210    
211    
212  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) ---
213  setMethod("cbind", signature(a = "Matrix", b = "Matrix"),  ## ----  *and* 'Matrix' must have been *installed* by R >= 2.2.x
214            function(a, b, ...) {  
215                da <- Dim(a)  if(paste(R.version$major, R.version$minor, sep=".") >= "2.2") {
216                db <- Dim(b)  
217                if(da[1] != db[1])      ## The trivial methods :
218                    stop("Matrices must have same number of rows for cbind()ing")      setMethod("cbind2", signature(x = "Matrix", y = "NULL"),
219                  function(x, y) x)
220        setMethod("cbind2", signature(x = "Matrix", y = "missing"),
221                  function(x, y) x)
222        setMethod("cbind2", signature(x = "NULL", y="Matrix"),
223                  function(x, y) x)
224    
225        setMethod("rbind2", signature(x = "Matrix", y = "NULL"),
226                  function(x, y) x)
227        setMethod("rbind2", signature(x = "Matrix", y = "missing"),
228                  function(x, y) x)
229        setMethod("rbind2", signature(x = "NULL", y="Matrix"),
230                  function(x, y) x)
231    
232        ## Makes sure one gets x decent error message for the unimplemented cases:
233        setMethod("cbind2", signature(x = "Matrix", y = "Matrix"),
234                  function(x, y) {
235                      rowCheck(x,y)
236                      stop(gettextf("cbind2() method for (%s,%s) not-yet defined",
237                                    class(x), class(y)))
238            })            })
239    
240        ## Use a working fall back {particularly useful for sparse}:
241        ## FIXME: implement rbind2 via "cholmod" for C* and Tsparse ones
242        setMethod("rbind2", signature(x = "Matrix", y = "Matrix"),
243                  function(x, y) {
244                      colCheck(x,y)
245                      t(cbind2(t(x), t(y)))
246                  })
247    
248    }## R-2.2.x and newer

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

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