# SCM Repository

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

# Diff of /pkg/R/Matrix.R

revision 607, Fri Mar 4 17:33:03 2005 UTC revision 871, Fri Aug 26 17:26:49 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 = "Matrix", 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(as.numeric(NA), dim = d, dimnames = dimnames(from))            array(from@x, dim = d, dimnames = dimnames(from))
8        })        })
9
prMatrix <-
10      ## private function to be used as show() method possibly more than once      ## private function to be used as show() method possibly more than once
11      function(object) {  prMatrix <- function(object) {
12          d <- dim(object)          d <- dim(object)
13          cat(paste(d, collapse= " x "), " Matrix of class ",      cl <- class(object)
14              sQuote(class(object)),"\n", sep='')      cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
15          m <- as(object, "matrix")          m <- as(object, "matrix")
16          maxp <- getOption("max.print")          maxp <- getOption("max.print")
17          if(prod(d) <= maxp) print(m)          if(prod(d) <= maxp) print(m)
# Line 24  Line 23
23              print(tail(m, max(1, nr - n2)))              print(tail(m, max(1, nr - n2)))
24          }          }
25          ## DEBUG: cat("str(.):\n") ; str(object)          ## DEBUG: cat("str(.):\n") ; str(object)
26          invisible()      invisible(object)# as print() S3 methods do
27      }      }
28
29  setMethod("show", signature(object = "ddenseMatrix"), prMatrix)  setMethod("show", signature(object = "ddenseMatrix"), prMatrix)
30  ## this may go away {since sparse matrices need something better!} :
31    ##- ## FIXME: The following is only for the "dMatrix" objects that are not
32    ##- ##        "dense" nor "sparse" -- i.e. "packed" ones :
33    ##- ## But these could be printed better -- "." for structural zeros.
34    ##- setMethod("show", signature(object = "dMatrix"), prMatrix)
35    ##- ## and improve this as well:
36    ##- setMethod("show", signature(object = "pMatrix"), prMatrix)
37    ##- ## this should now be superfluous [keep for safety for the moment]:
38  setMethod("show", signature(object = "Matrix"), prMatrix)  setMethod("show", signature(object = "Matrix"), prMatrix)
39
40    ## should propagate to all subclasses:
41    setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))
42
43  setMethod("dim", signature(x = "Matrix"),  setMethod("dim", signature(x = "Matrix"),
44            function(x) x@Dim, valueClass = "integer")            function(x) x@Dim, valueClass = "integer")
45  setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)  setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
# Line 49  Line 58
58  setMethod("dimnames<-", signature(x = "Matrix", value = "list"),  setMethod("dimnames<-", signature(x = "Matrix", value = "list"),
59            dimnamesGets)            dimnamesGets)
60
61    setMethod("unname", signature("Matrix", force="missing"),
62              function(obj) { obj@Dimnames <- list(NULL,NULL); obj})
63
64  Matrix <-  Matrix <-
65      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
# Line 66  Line 77
77      as(val, "dgeMatrix")      as(val, "dgeMatrix")
78  }  }
79
80    ## Methods for operations where one argument is numeric
81
82  if(FALSE) { ##--- not-yet used -- {almost same code also in ./dgeMatrix.R }  ## Using as.matrix() and rbind()
83    ## in order to get dimnames from names {at least potentially}:
84
85  ## utility for as.Matrix() {which is currently invalid }  setMethod("%*%", signature(x = "Matrix", y = "numeric"),
86  Matrix.class <- function(x, tol = 0, symmetry = TRUE, unit.diagonal = TRUE,            function(x, y) callGeneric(x, as.matrix(y)))
triangularity = c(TRUE, TRUE),
orthogonality = c(TRUE, TRUE),
normality = c(TRUE, TRUE))
{
val <- "Matrix"
x <- as.matrix(x)
if (symmetry) {
if (is.Hermitian(x, tol)) val <- c("Hermitian", val)
}
if (triangularity[1]) {
if (is.LowerTriangular(x, tol)) {
val <- c("LowerTriangular", val)
if (unit.diagonal)
if (max(Mod(diag(x) - 1)) <= tol)
val <- c("UnitLowerTriangular", val)
}
}
if (triangularity[2]) {
if (is.UpperTriangular(x, tol)) {
val <- c("UpperTriangular", val)
if (unit.diagonal)
if (max(Mod(diag(x) - 1)) <= tol)
val <- c("UnitUpperTriangular", val)
}
}
if (orthogonality[1]) {
if (is.ColOrthonormal(x, tol)) {
val <- c("ColOrthoNormal", "ColOrthogonal", val)
} else {
if (Orthogonal.test(x, normal = FALSE) <= tol)
val <- c("ColOrthogonal", val)
}
}
if (orthogonality[2]) {
if (normality[2] && is.RowOrthonormal(x, tol)) {
val <- c("RowOrthoNormal", "RowOrthogonal", val)
} else {
if (Orthogonal.test(x, byrow = TRUE, normal = FALSE) <= tol)
val <- c("RowOrthogonal", val)
}
}
val
}
87
88  as.Matrix <- function(x, tol = .Machine\$double.eps)  setMethod("%*%", signature(x = "numeric", y = "Matrix"),
89  {            function(x, y) callGeneric(rbind(x), y))
90      asObject(if (inherits(x, "Matrix")) x else as.matrix(x),
91               Matrix.class(x, tol = tol))  setMethod("crossprod", signature(x = "Matrix", y = "numeric"),
92  }            function(x, y = NULL) callGeneric(x, as.matrix(y)))
93
94  }## not-yet used  setMethod("crossprod", signature(x = "numeric", y = "Matrix"),
95              function(x, y = NULL)  callGeneric(rbind(x), y))
96
97    setMethod("solve", signature(a = "Matrix", b = "numeric"),
98              function(a, b, ...) callGeneric(a, as.matrix(b)))
99
100    ### --------------------------------------------------------------------------
101    ###
102    ### Subsetting "["  and
103    ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":
104
105    ## "x[]":
106    setMethod("[", signature(x = "Matrix",
107                             i = "missing", j = "missing", drop = "ANY"),
108              function (x, i, j, drop) x)
109    ## missing 'drop' --> 'drop = TRUE'
110    ##                     -----------
111    ## select rows
112    setMethod("[", signature(x = "Matrix", i = "numeric", j = "missing",
113                             drop = "missing"),
114              function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))
115    ## select columns
116    setMethod("[", signature(x = "Matrix", i = "missing", j = "numeric",
117                             drop = "missing"),
118              function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))
119    setMethod("[", signature(x = "Matrix", i = "numeric", j = "numeric",
120                             drop = "missing"),
121              function(x,i,j, drop) callGeneric(x, i=i, j=j, drop= TRUE))
122
123    ## "FIXME:"
124    ## How can we get at   A[ ij ]  where ij is (i,j) 2-column matrix?
125    ##  and                A[ LL ]  where LL is a logical *vector*
126
127
128
129    ### "[<-" : -----------------
130
131    ## x[] <- value :
132    setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
133                                    value = "vector"),##  double/logical/...
134              function (x, value) { x@x <- value ; validObject(x); x })
135
136    ## Otherwise (value is not "vector"): bail out
137    setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
138                                    value = "ANY"),
139              function (x, i, j, value) stop("RHS 'value' must be of class \"vector\""))
140
141
142
143    if(FALSE) ## The following can't work as long as cbind is function(..., *)
144    setMethod("cbind", signature(a = "Matrix", b = "Matrix"),
145              function(a, b, ...) {
146                  da <- Dim(a)
147                  db <- Dim(b)
148                  if(da[1] != db[1])
149                      stop("Matrices must have same number of rows for cbind()ing")
150              })

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