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 886 - (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 : maechler 698 if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")
7 :     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 698 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)
21 :     print(head(m, max(1, n2)))
22 :     cat("\n ..........\n\n")
23 :     print(tail(m, max(1, nr - n2)))
24 :     }
25 :     ## DEBUG: cat("str(.):\n") ; str(object)
26 : maechler 676 invisible(object)# as print() S3 methods do
27 : maechler 618 }
28 : bates 10
29 : maechler 607 setMethod("show", signature(object = "ddenseMatrix"), prMatrix)
30 : maechler 676
31 : maechler 698 ##- ## 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 : maechler 512 setMethod("show", signature(object = "Matrix"), prMatrix)
39 :    
40 : maechler 676 ## should propagate to all subclasses:
41 : maechler 658 setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))
42 :    
43 : maechler 886 ## Note that isSymmetric is *not* exported
44 :     setMethod("isSymmetric", signature(object = "symmetricMatrix"),
45 :     function(object) TRUE)
46 :     setMethod("isSymmetric", signature(object = "triangularMatrix"),
47 :     ## FIXME: 'TRUE' if *diagonal*, i.e. return(isDiagonal(object))
48 :     function(object) FALSE)
49 :    
50 : maechler 579 setMethod("dim", signature(x = "Matrix"),
51 : maechler 698 function(x) x@Dim, valueClass = "integer")
52 : maechler 579 setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
53 : maechler 607 ## not exported but used more than once for "dimnames<-" method :
54 :     ## -- or do only once for all "Matrix" classes ??
55 :     dimnamesGets <- function (x, value) {
56 :     d <- dim(x)
57 :     if (!is.list(value) || length(value) != 2 ||
58 : maechler 698 !(is.null(v1 <- value[[1]]) || length(v1) == d[1]) ||
59 :     !(is.null(v2 <- value[[2]]) || length(v2) == d[2]))
60 :     stop(sprintf("invalid dimnames given for '%s' object", class(x)))
61 : maechler 607 x@Dimnames <- list(if(!is.null(v1)) as.character(v1),
62 : maechler 698 if(!is.null(v2)) as.character(v2))
63 : maechler 607 x
64 :     }
65 :     setMethod("dimnames<-", signature(x = "Matrix", value = "list"),
66 : maechler 698 dimnamesGets)
67 : maechler 579
68 : maechler 658 setMethod("unname", signature("Matrix", force="missing"),
69 : maechler 698 function(obj) { obj@Dimnames <- list(NULL,NULL); obj})
70 : maechler 607
71 : bates 10 Matrix <-
72 :     function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
73 :     {
74 :     if (is(data, "Matrix")) return(data)
75 :     if (is.matrix(data)) { val <- data }
76 : maechler 538 else { ## cut & paste from "base::matrix" :
77 : maechler 698 if (missing(nrow))
78 :     nrow <- ceiling(length(data)/ncol)
79 :     else if (missing(ncol))
80 :     ncol <- ceiling(length(data)/nrow)
81 :     val <- .Internal(matrix(data, nrow, ncol, byrow))
82 :     dimnames(val) <- dimnames
83 : bates 10 }
84 : bates 477 as(val, "dgeMatrix")
85 : bates 10 }
86 :    
87 : bates 683 ## Methods for operations where one argument is numeric
88 : maechler 512
89 : maechler 698 ## Using as.matrix() and rbind()
90 :     ## in order to get dimnames from names {at least potentially}:
91 :    
92 : bates 683 setMethod("%*%", signature(x = "Matrix", y = "numeric"),
93 : maechler 698 function(x, y) callGeneric(x, as.matrix(y)))
94 : bates 683
95 :     setMethod("%*%", signature(x = "numeric", y = "Matrix"),
96 : maechler 698 function(x, y) callGeneric(rbind(x), y))
97 : bates 683
98 :     setMethod("crossprod", signature(x = "Matrix", y = "numeric"),
99 : maechler 698 function(x, y = NULL) callGeneric(x, as.matrix(y)))
100 : bates 683
101 :     setMethod("crossprod", signature(x = "numeric", y = "Matrix"),
102 : maechler 698 function(x, y = NULL) callGeneric(rbind(x), y))
103 : bates 683
104 :     setMethod("solve", signature(a = "Matrix", b = "numeric"),
105 : maechler 698 function(a, b, ...) callGeneric(a, as.matrix(b)))
106 : maechler 848
107 : maechler 871 ### --------------------------------------------------------------------------
108 :     ###
109 :     ### Subsetting "[" and
110 :     ### SubAssign "[<-" : The "missing" cases can be dealt with here, "at the top":
111 : maechler 868
112 : maechler 886 ## Using "index" for indices should allow
113 : maechler 875 ## integer (numeric), logical, or character (names!) indices :
114 :    
115 : maechler 868 ## "x[]":
116 :     setMethod("[", signature(x = "Matrix",
117 :     i = "missing", j = "missing", drop = "ANY"),
118 :     function (x, i, j, drop) x)
119 :     ## missing 'drop' --> 'drop = TRUE'
120 :     ## -----------
121 :     ## select rows
122 : maechler 886 setMethod("[", signature(x = "Matrix", i = "index", j = "missing",
123 : maechler 868 drop = "missing"),
124 :     function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))
125 :     ## select columns
126 : maechler 886 setMethod("[", signature(x = "Matrix", i = "missing", j = "index",
127 : maechler 868 drop = "missing"),
128 :     function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))
129 : maechler 886 setMethod("[", signature(x = "Matrix", i = "index", j = "index",
130 : maechler 868 drop = "missing"),
131 :     function(x,i,j, drop) callGeneric(x, i=i, j=j, drop= TRUE))
132 :    
133 : maechler 875 ## bail out if any of (i,j,drop) is "non-sense"
134 :     setMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY", drop = "ANY"),
135 :     function(x,i,j, drop)
136 :     stop("invalid or not-yet-implemented 'Matrix' subsetting"))
137 :    
138 : maechler 868 ## "FIXME:"
139 :     ## How can we get at A[ ij ] where ij is (i,j) 2-column matrix?
140 :     ## and A[ LL ] where LL is a logical *vector*
141 : maechler 886 ## -> [.data.frame uses nargs() - can we do this in the *generic* ?
142 : maechler 868
143 :    
144 : maechler 871 ### "[<-" : -----------------
145 : maechler 868
146 : maechler 871 ## x[] <- value :
147 :     setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
148 : maechler 886 value = "index"),## double/logical/...
149 : maechler 871 function (x, value) { x@x <- value ; validObject(x); x })
150 :    
151 : maechler 886 ## Otherwise (value is not "index"): bail out
152 : maechler 871 setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
153 :     value = "ANY"),
154 : maechler 875 function (x, i, j, value)
155 : maechler 886 if(!is(value,"index"))
156 :     stop("RHS 'value' must be of class \"index\"")
157 : maechler 875 else stop("unimplemented 'Matrix[<-' method"))
158 : maechler 871
159 :    
160 :    
161 : maechler 875
162 : maechler 848 if(FALSE) ## The following can't work as long as cbind is function(..., *)
163 :     setMethod("cbind", signature(a = "Matrix", b = "Matrix"),
164 :     function(a, b, ...) {
165 :     da <- Dim(a)
166 :     db <- Dim(b)
167 :     if(da[1] != db[1])
168 :     stop("Matrices must have same number of rows for cbind()ing")
169 :     })

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