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 579 - (view) (download)

1 : maechler 512 prMatrix <-
2 :     ## private function to be used as show() method possibly more than once
3 :     function(object) {
4 :     d <- dim(object)
5 :     cat(paste(d, collapse= " x "), " Matrix of class ",
6 :     sQuote(class(object)),"\n", sep='')
7 :     m <- as(object, "matrix")
8 :     maxp <- getOption("max.print")
9 :     if(prod(d) <= maxp) print(m)
10 :     else { ## d[1] > maxp / d[2] >= nr :
11 :     nr <- maxp %/% d[2]
12 :     n2 <- ceiling(nr / 2)
13 :     print(head(m, max(1, n2)))
14 :     cat("\n ..........\n\n")
15 :     print(tail(m, max(1, nr - n2)))
16 :     }
17 :     ## DEBUG: cat("str(.):\n") ; str(object)
18 :     invisible()
19 :     }
20 : bates 10
21 : maechler 512 setMethod("show", signature(object = "Matrix"), prMatrix)
22 :    
23 : maechler 579 if(FALSE) {## FIXME: we should do this here (for all subclasses),
24 :     ## ----- but it coerces some to "Matrix" {with no @x slot}
25 :     setMethod("dim", signature(x = "Matrix"),
26 :     function(x) x@Dim, valueClass = "integer")
27 :     setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
28 :     }# FIXME
29 :    
30 : bates 10 Matrix <-
31 :     function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
32 :     {
33 :     if (is(data, "Matrix")) return(data)
34 :     if (is.matrix(data)) { val <- data }
35 : maechler 538 else { ## cut & paste from "base::matrix" :
36 : bates 10 if (missing(nrow))
37 :     nrow <- ceiling(length(data)/ncol)
38 :     else if (missing(ncol))
39 :     ncol <- ceiling(length(data)/nrow)
40 :     val <- .Internal(matrix(data, nrow, ncol, byrow))
41 :     dimnames(val) <- dimnames
42 :     }
43 : bates 477 as(val, "dgeMatrix")
44 : bates 10 }
45 :    
46 : maechler 512
47 : maechler 579 if(FALSE) { ##--- not-yet used -- {almost same code also in ./dgeMatrix.R }
48 : maechler 512
49 : maechler 579 ## utility for as.Matrix() {which is currently invalid }
50 : bates 10 Matrix.class <- function(x, tol = 0, symmetry = TRUE, unit.diagonal = TRUE,
51 :     triangularity = c(TRUE, TRUE),
52 : maechler 499 orthogonality = c(TRUE, TRUE),
53 :     normality = c(TRUE, TRUE))
54 : bates 10 {
55 :     val <- "Matrix"
56 :     x <- as.matrix(x)
57 :     if (symmetry) {
58 :     if (is.Hermitian(x, tol)) val <- c("Hermitian", val)
59 :     }
60 :     if (triangularity[1]) {
61 :     if (is.LowerTriangular(x, tol)) {
62 :     val <- c("LowerTriangular", val)
63 :     if (unit.diagonal)
64 :     if (max(Mod(diag(x) - 1)) <= tol)
65 :     val <- c("UnitLowerTriangular", val)
66 :     }
67 :     }
68 :     if (triangularity[2]) {
69 :     if (is.UpperTriangular(x, tol)) {
70 :     val <- c("UpperTriangular", val)
71 :     if (unit.diagonal)
72 :     if (max(Mod(diag(x) - 1)) <= tol)
73 :     val <- c("UnitUpperTriangular", val)
74 :     }
75 :     }
76 :     if (orthogonality[1]) {
77 :     if (is.ColOrthonormal(x, tol)) {
78 :     val <- c("ColOrthoNormal", "ColOrthogonal", val)
79 :     } else {
80 :     if (Orthogonal.test(x, normal = FALSE) <= tol)
81 :     val <- c("ColOrthogonal", val)
82 :     }
83 :     }
84 :     if (orthogonality[2]) {
85 :     if (normality[2] && is.RowOrthonormal(x, tol)) {
86 :     val <- c("RowOrthoNormal", "RowOrthogonal", val)
87 :     } else {
88 :     if (Orthogonal.test(x, byrow = TRUE, normal = FALSE) <= tol)
89 :     val <- c("RowOrthogonal", val)
90 :     }
91 :     }
92 :     val
93 :     }
94 :    
95 :     as.Matrix <- function(x, tol = .Machine$double.eps)
96 :     {
97 : maechler 499 asObject(if (inherits(x, "Matrix")) x else as.matrix(x),
98 :     Matrix.class(x, tol = tol))
99 : bates 10 }
100 : maechler 512
101 : 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