SCM Repository

[matrix] Diff of /pkg/R/Matrix.R
 [matrix] / pkg / R / Matrix.R

Diff of /pkg/R/Matrix.R

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)
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