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 946, Wed Sep 28 08:56:42 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    ## Move this to ./Auxiliaries.R
102    .bail.out.1 <- function(fun, cl) {
103        stop(gettextf('not-yet-implemented method for %s(<%s>)', fun, cl),
104             call. = FALSE)
105    }
106    .bail.out.2 <- function(fun, cl1, cl2) {
107        stop(gettextf('not-yet-implemented method for %s(<%s>, <%s>)',
108                      fun, cl1, cl2), call. = FALSE)
109    }
110    
111    setMethod("crossprod", signature(x = "Matrix", y = "ANY"),
112              function (x, y = NULL) .bail.out.2(.Generic, class(x), class(y)))
113    
114    setMethod("t", signature(x = "Matrix"),
115              function(x) .bail.out.1(.Generic, class(x)))
116    
117    ## Group Methods (bail-out)
118    setMethod("Compare", signature(e1 = "Matrix", e2 = "Matrix"),
119              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
120    setMethod("Compare", signature(e1 = "Matrix", e2 = "ANY"),
121              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
122    setMethod("Compare", signature(e1 = "ANY", e2 = "Matrix"),
123              function(e1, e2) .bail.out.2(.Generic, class(e1), class(e2)))
124    
125    
126    
127  ### --------------------------------------------------------------------------  ### --------------------------------------------------------------------------
128  ###  ###
129  ### Subsetting "["  and  ### Subsetting "["  and
130  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":  ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":
131    
132    ## Using "index" for indices should allow
133    ## integer (numeric), logical, or character (names!) indices :
134    
135  ## "x[]":  ## "x[]":
136  setMethod("[", signature(x = "Matrix",  setMethod("[", signature(x = "Matrix",
137                           i = "missing", j = "missing", drop = "ANY"),                           i = "missing", j = "missing", drop = "ANY"),
# Line 109  Line 139 
139  ## missing 'drop' --> 'drop = TRUE'  ## missing 'drop' --> 'drop = TRUE'
140  ##                     -----------  ##                     -----------
141  ## select rows  ## select rows
142  setMethod("[", signature(x = "Matrix", i = "numeric", j = "missing",  setMethod("[", signature(x = "Matrix", i = "index", j = "missing",
143                           drop = "missing"),                           drop = "missing"),
144            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))            function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))
145  ## select columns  ## select columns
146  setMethod("[", signature(x = "Matrix", i = "missing", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "missing", j = "index",
147                           drop = "missing"),                           drop = "missing"),
148            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))            function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))
149  setMethod("[", signature(x = "Matrix", i = "numeric", j = "numeric",  setMethod("[", signature(x = "Matrix", i = "index", j = "index",
150                           drop = "missing"),                           drop = "missing"),
151            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))
152    
153    ## bail out if any of (i,j,drop) is "non-sense"
154    setMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", drop = "ANY"),
155              function(x,i,j, drop)
156              stop("invalid or not-yet-implemented 'Matrix' subsetting"))
157    
158  ## "FIXME:"  ## "FIXME:"
159  ## 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?
160  ##  and                A[ LL ]  where LL is a logical *vector*  ##  and                A[ LL ]  where LL is a logical *vector*
161    ## -> [.data.frame uses nargs() - can we do this in the *generic* ?
162    
163    
164  ### "[<-" : -----------------  ### "[<-" : -----------------
165    
166  ## x[] <- value :  ## x[] <- value :
167  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",  setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
168                                  value = "vector"),##  double/logical/...                                  value = "index"),##  double/logical/...
169            function (x, value) { x@x <- value ; validObject(x); x })            function (x, value) { x@x <- value ; validObject(x); x })
170    
171  ## Otherwise (value is not "vector"): bail out  ## Otherwise (value is not "index"): bail out
172  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
173                                  value = "ANY"),                                  value = "ANY"),
174            function (x, i, j, value) stop("RHS 'value' must be of class \"vector\""))            function (x, i, j, value)
175                     if(!is(value,"index"))
176                     stop("RHS 'value' must be of class \"index\"")
177                     else stop("not-yet-implemented 'Matrix[<-' method"))
178    
179    
180    
181  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) ---
182  setMethod("cbind", signature(a = "Matrix", b = "Matrix"),  ## ----  *and* 'Matrix' must have been *installed* by R >= 2.2.x
183            function(a, b, ...) {  
184                da <- Dim(a)  if(paste(R.version$major, R.version$minor, sep=".") >= "2.2") {
185                db <- Dim(b)  
186                if(da[1] != db[1])      ## The trivial methods :
187                    stop("Matrices must have same number of rows for cbind()ing")      setMethod("cbind2", signature(x = "Matrix", y = "NULL"),
188                  function(x, y) x)
189        setMethod("cbind2", signature(x = "Matrix", y = "missing"),
190                  function(x, y) x)
191        setMethod("cbind2", signature(x = "NULL", y="Matrix"),
192                  function(x, y) x)
193    
194        setMethod("rbind2", signature(x = "Matrix", y = "NULL"),
195                  function(x, y) x)
196        setMethod("rbind2", signature(x = "Matrix", y = "missing"),
197                  function(x, y) x)
198        setMethod("rbind2", signature(x = "NULL", y="Matrix"),
199                  function(x, y) x)
200    
201        ## Makes sure one gets x decent error message for the unimplemented cases:
202        setMethod("cbind2", signature(x = "Matrix", y = "Matrix"),
203                  function(x, y) {
204                      rowCheck(x,y)
205                      stop(gettextf("cbind2() method for (%s,%s) not-yet defined",
206                                    class(x), class(y)))
207                  })
208    
209        setMethod("rbind2", signature(x = "Matrix", y = "Matrix"),
210                  function(x, y) {
211                      colCheck(x,y)
212                      stop(gettextf("rbind2() method for (%s,%s) not-yet defined",
213                                    class(x), class(y)))
214            })            })
215    }## R-2.2.x and newer

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

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