SCM

SCM Repository

[matrix] Annotation of /pkg/R/Matrix.R
ViewVC logotype

Annotation of /pkg/R/Matrix.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 676 - (view) (download)

1 : maechler 607 #### Toplevel ``virtual'' class "Matrix"
2 :    
3 :     ## probably not needed eventually:
4 : maechler 618 setAs(from = "ddenseMatrix", to = "matrix",
5 : maechler 607 function(from) {
6 :     if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")
7 : maechler 618 array(from@x, dim = d, dimnames = dimnames(from))
8 : maechler 607 })
9 :    
10 : maechler 618 ## 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 : maechler 657 cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
15 : maechler 676 ##- no longer needed: have no objects of virtual classes:
16 :     ## if(cl == "Matrix") { ## have no data slot
17 :     ## cat("Dim = ", d)
18 :     ## if(any(sapply(object@Dimnames,length) > 0)) {
19 :     ## cat("; Dimnames = ")
20 :     ## str(object@Dimnames)
21 :     ## }
22 :     ## cat("\n")
23 :     ## } else { # not "Matrix", hence have data 'x' slot
24 : maechler 512 m <- as(object, "matrix")
25 :     maxp <- getOption("max.print")
26 :     if(prod(d) <= maxp) print(m)
27 :     else { ## d[1] > maxp / d[2] >= nr :
28 :     nr <- maxp %/% d[2]
29 :     n2 <- ceiling(nr / 2)
30 :     print(head(m, max(1, n2)))
31 :     cat("\n ..........\n\n")
32 :     print(tail(m, max(1, nr - n2)))
33 :     }
34 :     ## DEBUG: cat("str(.):\n") ; str(object)
35 : maechler 676 ## }
36 :     invisible(object)# as print() S3 methods do
37 : maechler 618 }
38 : bates 10
39 : maechler 607 setMethod("show", signature(object = "ddenseMatrix"), prMatrix)
40 : maechler 676
41 :     setMethod("show", signature(object = "sparseMatrix"),
42 :     function(object) {
43 :     d <- dim(object)
44 :     cl <- class(object)
45 :     cat(sprintf('%d x %d sparse Matrix of class "%s"\n', d[1], d[2], cl))
46 :    
47 :     maxp <- getOption("max.print")
48 :     if(prod(d) <= maxp) print(as(object, "matrix"))
49 :     else { ## d[1] > maxp / d[2] >= nr :
50 :     cat("\n Not printing large sparse matrix -- maybe increase options(max.print)\n")
51 :     if(FALSE) { ### need storage economic "[,]" method for sparse!!
52 :     nr <- maxp %/% d[2]
53 :     n2 <- ceiling(nr / 2)
54 :     print(head(m, max(1, n2)))
55 :     cat("\n ..........\n\n")
56 :     print(tail(m, max(1, nr - n2)))
57 :     }
58 :     }
59 :     ## DEBUG: cat("str(.):\n") ; str(object)
60 :     invisible(object)
61 :     })
62 :    
63 : maechler 607 ## this may go away {since sparse matrices need something better!} :
64 : maechler 512 setMethod("show", signature(object = "Matrix"), prMatrix)
65 :    
66 : maechler 676 ## should propagate to all subclasses:
67 : maechler 658 setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))
68 :    
69 : maechler 579 setMethod("dim", signature(x = "Matrix"),
70 :     function(x) x@Dim, valueClass = "integer")
71 :     setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
72 : maechler 607 ## not exported but used more than once for "dimnames<-" method :
73 :     ## -- or do only once for all "Matrix" classes ??
74 :     dimnamesGets <- function (x, value) {
75 :     d <- dim(x)
76 :     if (!is.list(value) || length(value) != 2 ||
77 :     !(is.null(v1 <- value[[1]]) || length(v1) == d[1]) ||
78 :     !(is.null(v2 <- value[[2]]) || length(v2) == d[2]))
79 :     stop(sprintf("invalid dimnames given for '%s' object", class(x)))
80 :     x@Dimnames <- list(if(!is.null(v1)) as.character(v1),
81 :     if(!is.null(v2)) as.character(v2))
82 :     x
83 :     }
84 :     setMethod("dimnames<-", signature(x = "Matrix", value = "list"),
85 :     dimnamesGets)
86 : maechler 579
87 : maechler 658 setMethod("unname", signature("Matrix", force="missing"),
88 :     function(obj) { obj@Dimnames <- list(NULL,NULL); obj})
89 : maechler 607
90 : bates 10 Matrix <-
91 :     function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
92 :     {
93 :     if (is(data, "Matrix")) return(data)
94 :     if (is.matrix(data)) { val <- data }
95 : maechler 538 else { ## cut & paste from "base::matrix" :
96 : bates 10 if (missing(nrow))
97 :     nrow <- ceiling(length(data)/ncol)
98 :     else if (missing(ncol))
99 :     ncol <- ceiling(length(data)/nrow)
100 :     val <- .Internal(matrix(data, nrow, ncol, byrow))
101 :     dimnames(val) <- dimnames
102 :     }
103 : bates 477 as(val, "dgeMatrix")
104 : bates 10 }
105 :    
106 : maechler 512
107 : maechler 579 if(FALSE) { ##--- not-yet used -- {almost same code also in ./dgeMatrix.R }
108 : maechler 512
109 : maechler 579 ## utility for as.Matrix() {which is currently invalid }
110 : bates 10 Matrix.class <- function(x, tol = 0, symmetry = TRUE, unit.diagonal = TRUE,
111 :     triangularity = c(TRUE, TRUE),
112 : maechler 499 orthogonality = c(TRUE, TRUE),
113 :     normality = c(TRUE, TRUE))
114 : bates 10 {
115 :     val <- "Matrix"
116 :     x <- as.matrix(x)
117 :     if (symmetry) {
118 :     if (is.Hermitian(x, tol)) val <- c("Hermitian", val)
119 :     }
120 :     if (triangularity[1]) {
121 :     if (is.LowerTriangular(x, tol)) {
122 :     val <- c("LowerTriangular", val)
123 :     if (unit.diagonal)
124 :     if (max(Mod(diag(x) - 1)) <= tol)
125 :     val <- c("UnitLowerTriangular", val)
126 :     }
127 :     }
128 :     if (triangularity[2]) {
129 :     if (is.UpperTriangular(x, tol)) {
130 :     val <- c("UpperTriangular", val)
131 :     if (unit.diagonal)
132 :     if (max(Mod(diag(x) - 1)) <= tol)
133 :     val <- c("UnitUpperTriangular", val)
134 :     }
135 :     }
136 :     if (orthogonality[1]) {
137 :     if (is.ColOrthonormal(x, tol)) {
138 :     val <- c("ColOrthoNormal", "ColOrthogonal", val)
139 :     } else {
140 :     if (Orthogonal.test(x, normal = FALSE) <= tol)
141 :     val <- c("ColOrthogonal", val)
142 :     }
143 :     }
144 :     if (orthogonality[2]) {
145 :     if (normality[2] && is.RowOrthonormal(x, tol)) {
146 :     val <- c("RowOrthoNormal", "RowOrthogonal", val)
147 :     } else {
148 :     if (Orthogonal.test(x, byrow = TRUE, normal = FALSE) <= tol)
149 :     val <- c("RowOrthogonal", val)
150 :     }
151 :     }
152 :     val
153 :     }
154 :    
155 :     as.Matrix <- function(x, tol = .Machine$double.eps)
156 :     {
157 : maechler 499 asObject(if (inherits(x, "Matrix")) x else as.matrix(x),
158 :     Matrix.class(x, tol = tol))
159 : bates 10 }
160 : maechler 512
161 : maechler 579 }## not-yet used

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