# SCM Repository

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

# Diff of /pkg/R/Matrix.R

revision 477, Wed Feb 2 14:14:59 2005 UTC revision 871, Fri Aug 26 17:26:49 2005 UTC
# Line 1  Line 1
1  setMethod("show", signature(object = "Matrix"),  #### Toplevel ``virtual'' class "Matrix"
2            function(object) print(as(object, "matrix")))
3    ## probably not needed eventually:
4    setAs(from = "ddenseMatrix", to = "matrix",
5          function(from) {
6              if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")
7              array(from@x, dim = d, dimnames = dimnames(from))
8          })
9
10    ## private function to be used as show() method possibly more than once
11    prMatrix <- function(object) {
12        d <- dim(object)
13        cl <- class(object)
14        cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
15        m <- as(object, "matrix")
16        maxp <- getOption("max.print")
17        if(prod(d) <= maxp) print(m)
18        else { ## d[1] > maxp / d[2] >= nr :
19            nr <- maxp %/% d[2]
20            n2 <- ceiling(nr / 2)
22            cat("\n ..........\n\n")
23            print(tail(m, max(1, nr - n2)))
24        }
25        ## DEBUG: cat("str(.):\n") ; str(object)
26        invisible(object)# as print() S3 methods do
27    }
28
29    setMethod("show", signature(object = "ddenseMatrix"), prMatrix)
30
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)
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"),
44              function(x) x@Dim, valueClass = "integer")
45    setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
46    ## not exported but used more than once for "dimnames<-" method :
47    ## -- or do only once for all "Matrix" classes ??
48    dimnamesGets <- function (x, value) {
49        d <- dim(x)
50        if (!is.list(value) || length(value) != 2 ||
51            !(is.null(v1 <- value[[1]]) || length(v1) == d[1]) ||
52            !(is.null(v2 <- value[[2]]) || length(v2) == d[2]))
53            stop(sprintf("invalid dimnames given for '%s' object", class(x)))
54        x@Dimnames <- list(if(!is.null(v1)) as.character(v1),
55                           if(!is.null(v2)) as.character(v2))
56        x
57    }
58    setMethod("dimnames<-", signature(x = "Matrix", value = "list"),
59              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)
66  {  {
67      if (is(data, "Matrix")) return(data)      if (is(data, "Matrix")) return(data)
68      if (is.matrix(data)) { val <- data }      if (is.matrix(data)) { val <- data }
69      else {      else { ## cut & paste from "base::matrix" :
70          if (missing(nrow))          if (missing(nrow))
71              nrow <- ceiling(length(data)/ncol)              nrow <- ceiling(length(data)/ncol)
72          else if (missing(ncol))          else if (missing(ncol))
# Line 17  Line 77
77      as(val, "dgeMatrix")      as(val, "dgeMatrix")
78  }  }
79
80  Matrix.class <- function(x, tol = 0, symmetry = TRUE, unit.diagonal = TRUE,  ## Methods for operations where one argument is numeric
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
}
81
82  as.Matrix <- function(x, tol = .Machine\$double.eps)  ## Using as.matrix() and rbind()
83  {  ## in order to get dimnames from names {at least potentially}:
84      if (inherits(x, "Matrix")) return(asObject(x, Matrix.class(x, tol = tol)))
85      asObject(as.matrix(x), Matrix.class(x, tol = tol))  setMethod("%*%", signature(x = "Matrix", y = "numeric"),
86  }            function(x, y) callGeneric(x, as.matrix(y)))
87
88    setMethod("%*%", signature(x = "numeric", y = "Matrix"),
89              function(x, y) callGeneric(rbind(x), y))
90
91    setMethod("crossprod", signature(x = "Matrix", y = "numeric"),
92              function(x, y = NULL) callGeneric(x, as.matrix(y)))
93
94    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.477 changed lines Added in v.871