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 949, Wed Sep 28 09:17:08 2005 UTC
# Line 7  Line 7 
7            array(from@x, dim = d, dimnames = dimnames(from))            array(from@x, dim = d, dimnames = dimnames(from))
8        })        })
9    
10  ## private function to be used as show() method possibly more than once  setMethod("show", signature(object = "ddenseMatrix"),
11  prMatrix <- function(object) {            function(object) prMatrix(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)  
12    
13  ##- ## FIXME: The following is only for the "dMatrix" objects that are not  ##- ## FIXME: The following is only for the "dMatrix" objects that are not
14  ##- ##        "dense" nor "sparse" -- i.e. "packed" ones :  ##- ##        "dense" nor "sparse" -- i.e. "packed" ones :
# Line 35  Line 17 
17  ##- ## and improve this as well:  ##- ## and improve this as well:
18  ##- setMethod("show", signature(object = "pMatrix"), prMatrix)  ##- setMethod("show", signature(object = "pMatrix"), prMatrix)
19  ##- ## this should now be superfluous [keep for safety for the moment]:  ##- ## this should now be superfluous [keep for safety for the moment]:
20  setMethod("show", signature(object = "Matrix"), prMatrix)  setMethod("show", signature(object = "Matrix"),
21              function(object) prMatrix(object))
22    
23  ## should propagate to all subclasses:  ## should propagate to all subclasses:
24  setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))  setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))
25    
26    ## Note that isSymmetric is *not* exported
27    setMethod("isSymmetric", signature(object = "symmetricMatrix"),
28              function(object) TRUE)
29    setMethod("isSymmetric", signature(object = "triangularMatrix"),
30              ## FIXME: 'TRUE' if *diagonal*, i.e. return(isDiagonal(object))
31              function(object) FALSE)
32    setMethod("isDiagonal", signature(object = "sparseMatrix"),
33              function(object) {
34                  gT <- as(object, "TsparseMatrix")
35                  all(gT@i == gT@j)
36              })
37    
38  setMethod("dim", signature(x = "Matrix"),  setMethod("dim", signature(x = "Matrix"),
39            function(x) x@Dim, valueClass = "integer")            function(x) x@Dim, valueClass = "integer")
40  setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)  setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
# Line 97  Line 92 
92  setMethod("solve", signature(a = "Matrix", b = "numeric"),  setMethod("solve", signature(a = "Matrix", b = "numeric"),
93            function(a, b, ...) callGeneric(a, as.matrix(b)))            function(a, b, ...) callGeneric(a, as.matrix(b)))
94    
95    ## bail-out methods in order to get better error messages
96    setMethod("%*%", signature(x = "Matrix", y = "Matrix"),
97              function (x, y)
98              stop(gettextf('not-yet-implemented method for <%s> %%*%% <%s>',
99                            class(x), class(y))))
100    
101    setMethod("crossprod", signature(x = "Matrix", y = "ANY"),
102              function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y)))
103    
104    setMethod("t", signature(x = "Matrix"),
105              function(x) .bail.out.1(.Generic, class(x)))
106    
107    ## Group Methods (bail-out)
108    setMethod("Compare", signature(e1 = "Matrix", e2 = "Matrix"),
109              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
110    setMethod("Compare", signature(e1 = "Matrix", e2 = "ANY"),
111              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
112    setMethod("Compare", signature(e1 = "ANY", e2 = "Matrix"),
113              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
114    
115    
116    
117  ### --------------------------------------------------------------------------  ### --------------------------------------------------------------------------
118  ###  ###
119  ### Subsetting "["  and  ### Subsetting "["  and
120  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":
121    
122    ## Using "index" for indices should allow
123    ## integer (numeric), logical, or character (names!) indices :
124    
125  ## "x[]":  ## "x[]":
126  setMethod("[", signature(x = "Matrix",  setMethod("[", signature(x = "Matrix",
127                           i = "missing", j = "missing", drop = "ANY"),                           i = "missing", j = "missing", drop = "ANY"),
# Line 109  Line 129 
129  ## missing 'drop' --> 'drop = TRUE'  ## missing 'drop' --> 'drop = TRUE'
130  ##                     -----------  ##                     -----------
131  ## select rows  ## select rows
132  setMethod("[", signature(x = "Matrix", i = "numeric", j = "missing",  setMethod("[", signature(x = "Matrix", i = "index", j = "missing",
133                           drop = "missing"),                           drop = "missing"),
134            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))
135  ## select columns  ## select columns
136  setMethod("[", signature(x = "Matrix", i = "missing", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "missing", j = "index",
137                           drop = "missing"),                           drop = "missing"),
138            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))
139  setMethod("[", signature(x = "Matrix", i = "numeric", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "index", j = "index",
140                           drop = "missing"),                           drop = "missing"),
141            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))
142    
143    ## bail out if any of (i,j,drop) is "non-sense"
144    setMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", drop = "ANY"),
145              function(x,i,j, drop)
146              stop("invalid or not-yet-implemented 'Matrix' subsetting"))
147    
148  ## "FIXME:"  ## "FIXME:"
149  ## 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?
150  ##  and                A[ LL ]  where LL is a logical *vector*  ##  and                A[ LL ]  where LL is a logical *vector*
151    ## -> [.data.frame uses nargs() - can we do this in the *generic* ?
152    
153    
154  ### "[<-" : -----------------  ### "[<-" : -----------------
155    
156  ## x[] <- value :  ## x[] <- value :
157  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
158                                  value = "vector"),##  double/logical/...                                  value = "index"),##  double/logical/...
159            function (x, value) { x@x <- value ; validObject(x); x })            function (x, value) { x@x <- value ; validObject(x); x })
160    
161  ## Otherwise (value is not "vector"): bail out  ## Otherwise (value is not "index"): bail out
162  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
163                                  value = "ANY"),                                  value = "ANY"),
164            function (x, i, j, value) stop("RHS 'value' must be of class \"vector\""))            function (x, i, j, value)
165                     if(!is(value,"index"))
166                     stop("RHS 'value' must be of class \"index\"")
167                     else stop("not-yet-implemented 'Matrix[<-' method"))
168    
169    
170    
171    ## NOTE: the following only works for R 2.2.x (and later) ---
172    ## ----  *and* 'Matrix' must have been *installed* by R >= 2.2.x
173    
174    if(paste(R.version$major, R.version$minor, sep=".") >= "2.2") {
175    
176        ## The trivial methods :
177        setMethod("cbind2", signature(x = "Matrix", y = "NULL"),
178                  function(x, y) x)
179        setMethod("cbind2", signature(x = "Matrix", y = "missing"),
180                  function(x, y) x)
181        setMethod("cbind2", signature(x = "NULL", y="Matrix"),
182                  function(x, y) x)
183    
184        setMethod("rbind2", signature(x = "Matrix", y = "NULL"),
185                  function(x, y) x)
186        setMethod("rbind2", signature(x = "Matrix", y = "missing"),
187                  function(x, y) x)
188        setMethod("rbind2", signature(x = "NULL", y="Matrix"),
189                  function(x, y) x)
190    
191        ## Makes sure one gets x decent error message for the unimplemented cases:
192        setMethod("cbind2", signature(x = "Matrix", y = "Matrix"),
193                  function(x, y) {
194                      rowCheck(x,y)
195                      stop(gettextf("cbind2() method for (%s,%s) not-yet defined",
196                                    class(x), class(y)))
197                  })
198    
199  if(FALSE) ## The following can't work as long as cbind is function(..., *)      setMethod("rbind2", signature(x = "Matrix", y = "Matrix"),
200  setMethod("cbind", signature(a = "Matrix", b = "Matrix"),                function(x, y) {
201            function(a, b, ...) {                    colCheck(x,y)
202                da <- Dim(a)                    stop(gettextf("rbind2() method for (%s,%s) not-yet defined",
203                db <- Dim(b)                                  class(x), class(y)))
               if(da[1] != db[1])  
                   stop("Matrices must have same number of rows for cbind()ing")  
204            })            })
205    }## R-2.2.x and newer

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

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