SCM

SCM Repository

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

Annotation of /pkg/R/Auxiliaries.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1198 - (view) (download)

1 : maechler 632 #### "Namespace private" Auxiliaries such as method functions
2 :     #### (called from more than one place --> need to be defined early)
3 :    
4 : maechler 656 ## For %*% (M = Matrix; v = vector (double or integer {complex maybe?}):
5 :     .M.v <- function(x, y) callGeneric(x, as.matrix(y))
6 :     .v.M <- function(x, y) callGeneric(rbind(x), y)
7 : maechler 632
8 : maechler 656 .has.DN <- ## has non-trivial Dimnames slot?
9 :     function(x) !identical(list(NULL,NULL), x@Dimnames)
10 :    
11 : maechler 949 .bail.out.1 <- function(fun, cl) {
12 :     stop(gettextf('not-yet-implemented method for %s(<%s>)', fun, cl),
13 :     call. = FALSE)
14 :     }
15 :     .bail.out.2 <- function(fun, cl1, cl2) {
16 :     stop(gettextf('not-yet-implemented method for %s(<%s>, <%s>)',
17 :     fun, cl1, cl2), call. = FALSE)
18 :     }
19 :    
20 : maechler 632 ## chol() via "dpoMatrix"
21 :     cholMat <- function(x, pivot, LINPACK) {
22 :     px <- as(x, "dpoMatrix")
23 : bates 703 if (isTRUE(validObject(px, test=TRUE))) chol(px)
24 : maechler 632 else stop("'x' is not positive definite -- chol() undefined.")
25 :     }
26 : maechler 908
27 : maechler 954 dimCheck <- function(a, b) {
28 :     da <- dim(a)
29 :     db <- dim(b)
30 :     if(any(da != db))
31 :     stop(gettextf("Matrices must have same dimensions in %s",
32 :     deparse(sys.call(sys.parent()))),
33 :     call. = FALSE)
34 :     da
35 :     }
36 :    
37 : maechler 956 dimNamesCheck <- function(a, b) {
38 :     ## assume dimCheck() has happened before
39 :     nullDN <- list(NULL,NULL)
40 :     h.a <- !identical(nullDN, dna <- dimnames(a))
41 :     h.b <- !identical(nullDN, dnb <- dimnames(b))
42 :     if(h.a || h.b) {
43 : maechler 1084 if (!h.b) dna
44 :     else if(!h.a) dnb
45 : maechler 956 else { ## both have non-trivial dimnames
46 :     r <- dna # "default" result
47 :     for(j in 1:2) {
48 :     dn <- dnb[[j]]
49 :     if(is.null(r[[j]]))
50 :     r[[j]] <- dn
51 :     else if (!is.null(dn) && any(r[[j]] != dn))
52 :     warning(gettextf("dimnames [%d] mismatch in %s", j,
53 :     deparse(sys.call(sys.parent()))),
54 :     call. = FALSE)
55 :     }
56 :     r
57 :     }
58 :     }
59 :     else
60 :     nullDN
61 :     }
62 :    
63 : maechler 908 rowCheck <- function(a, b) {
64 :     da <- dim(a)
65 :     db <- dim(b)
66 :     if(da[1] != db[1])
67 :     stop(gettextf("Matrices must have same number of rows in %s",
68 :     deparse(sys.call(sys.parent()))),
69 :     call. = FALSE)
70 :     ## return the common nrow()
71 :     da[1]
72 :     }
73 :    
74 :     colCheck <- function(a, b) {
75 :     da <- dim(a)
76 :     db <- dim(b)
77 :     if(da[2] != db[2])
78 :     stop(gettextf("Matrices must have same number of columns in %s",
79 :     deparse(sys.call(sys.parent()))),
80 :     call. = FALSE)
81 :     ## return the common ncol()
82 :     da[2]
83 :     }
84 :    
85 : maechler 956 emptyColnames <- function(x)
86 :     {
87 :     ## Useful for compact printing of (parts) of sparse matrices
88 :     ## possibly dimnames(x) "==" NULL :
89 :     dimnames(x) <- list(dimnames(x)[[1]], rep("", dim(x)[2]))
90 :     x
91 :     }
92 : maechler 908
93 : maechler 919 prTriang <- function(x, digits = getOption("digits"),
94 :     justify = "none", right = TRUE)
95 :     {
96 :     ## modeled along stats:::print.dist
97 :     diag <- TRUE
98 :     upper <- x@uplo == "U"
99 :    
100 :     m <- as(x, "matrix")
101 :     cf <- format(m, digits = digits, justify = justify)
102 :     if(upper)
103 :     cf[row(cf) > col(cf)] <- "."
104 :     else
105 :     cf[row(cf) < col(cf)] <- "."
106 :     print(cf, quote = FALSE, right = right)
107 :     invisible(x)
108 :     }
109 :    
110 :     prMatrix <- function(x, digits = getOption("digits")) {
111 :     d <- dim(x)
112 :     cl <- class(x)
113 :     cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
114 :     maxp <- getOption("max.print")
115 :     if(prod(d) <= maxp) {
116 :     if(is(x, "triangularMatrix"))
117 :     prTriang(x, digits = digits)
118 :     else
119 :     print(as(x, "matrix"), digits = digits)
120 :     }
121 :     else { ## d[1] > maxp / d[2] >= nr :
122 :     m <- as(x, "matrix")
123 :     nr <- maxp %/% d[2]
124 :     n2 <- ceiling(nr / 2)
125 :     print(head(m, max(1, n2)))
126 :     cat("\n ..........\n\n")
127 :     print(tail(m, max(1, nr - n2)))
128 :     }
129 :     ## DEBUG: cat("str(.):\n") ; str(x)
130 :     invisible(x)# as print() S3 methods do
131 :     }
132 :    
133 :     ## For sparseness handling
134 :     non0ind <- function(x) {
135 :     if(is.numeric(x))
136 :     return(if((n <- length(x))) (0:(n-1))[x != 0] else integer(0))
137 :    
138 :     ## else return a (i,j) matrix of non-zero-indices
139 :    
140 :     stopifnot(is(x, "sparseMatrix"))
141 : maechler 925 if(is(x, "TsparseMatrix"))
142 : maechler 954 return(unique(cbind(x@i,x@j)))
143 :    
144 : maechler 919 isCol <- function(M) any("i" == slotNames(M))
145 :     .Call("compressed_non_0_ij", x, isCol(x), PACKAGE = "Matrix")
146 :     }
147 :    
148 : maechler 925 ### There is a test on this in ../tests/dgTMatrix.R !
149 : maechler 919 uniq <- function(x) {
150 : maechler 925 if(is(x, "TsparseMatrix")) {
151 : maechler 919 ## Purpose: produce a *unique* triplet representation:
152 :     ## by having (i,j) sorted and unique
153 :     ## -----------------------------------------------------------
154 :     ## The following is *not* efficient {but easy to program}:
155 :     if(is(x, "dgTMatrix")) as(as(x, "dgCMatrix"), "dgTMatrix")
156 :     else if(is(x, "lgTMatrix")) as(as(x, "lgCMatrix"), "lgTMatrix")
157 :     else stop("not implemented for class", class(x))
158 :    
159 :     } else x # not 'gT' ; i.e. "uniquely" represented in any case
160 :     }
161 :    
162 :     if(FALSE) ## try an "efficient" version
163 :     uniq_gT <- function(x)
164 :     {
165 :     ## Purpose: produce a *unique* triplet representation:
166 :     ## by having (i,j) sorted and unique
167 :     ## ----------------------------------------------------------------------
168 :     ## Arguments: a "gT" Matrix
169 :     stopifnot(is(x, "gTMatrix"))
170 :     if((n <- length(x@i)) == 0) return(x)
171 :     ii <- order(x@i, x@j)
172 :     if(any(ii != 1:n)) {
173 :     x@i <- x@i[ii]
174 :     x@j <- x@j[ii]
175 :     x@x <- x@x[ii]
176 :     }
177 :     ij <- x@i + nrow(x) * x@j
178 :     if(any(dup <- duplicated(ij))) {
179 :    
180 :     }
181 :     ### We should use a .Call() based utility for this!
182 :    
183 :     }
184 :    
185 : maechler 946 t_geMatrix <- function(x) {
186 :     x@x <- as.vector(t(array(x@x, dim = x@Dim))) # no dimnames here
187 :     x@Dim <- x@Dim[2:1]
188 :     x@Dimnames <- x@Dimnames[2:1]
189 :     ## FIXME: how to set factors?
190 :     x
191 :     }
192 :    
193 :     ## t( [dl]trMatrix ) and t( [dl]syMatrix ) :
194 :     t_trMatrix <- function(x) {
195 :     x@x <- as.vector(t(as(x, "matrix")))
196 :     x@Dim <- x@Dim[2:1]
197 :     x@Dimnames <- x@Dimnames[2:1]
198 :     x@uplo <- if (x@uplo == "U") "L" else "U"
199 :     # and keep x@diag
200 :     x
201 :     }
202 : maechler 956
203 :     fixupDense <- function(m, from) {
204 :     if(is(m, "triangularMatrix")) {
205 :     m@uplo <- from@uplo
206 :     m@diag <- from@diag
207 :     } else if(is(m, "symmetricMatrix")) {
208 :     m@uplo <- from@uplo
209 :     }
210 :     m
211 :     }
212 :    
213 :     ## -> ./ldenseMatrix.R :
214 :     l2d_Matrix <- function(from) {
215 :     stopifnot(is(from, "lMatrix"))
216 :     fixupDense(new(sub("^l", "d", class(from)),
217 :     x = as.double(from@x),
218 : maechler 1198 Dim = from@Dim, Dimnames = from@Dimnames),
219 : maechler 956 from)
220 : maechler 1198 ## FIXME: treat 'factors' smartly {not for triangular!}
221 : maechler 956 }
222 :    
223 :     if(FALSE)# unused
224 :     l2d_meth <- function(x) {
225 :     cl <- class(x)
226 :     as(callGeneric(as(x, sub("^l", "d", cl))), cl)
227 :     }
228 :    
229 :     ## -> ./ddenseMatrix.R :
230 :     d2l_Matrix <- function(from) {
231 :     stopifnot(is(from, "dMatrix"))
232 :     fixupDense(new(sub("^d", "l", class(from)),
233 : maechler 1198 Dim = from@Dim, Dimnames = from@Dimnames),
234 : maechler 956 from)
235 : maechler 1198 ## FIXME: treat 'factors' smartly {not for triangular!}
236 : maechler 956 }
237 : maechler 973
238 :    
239 :     try_as <- function(x, classes, tryAnyway = FALSE) {
240 :     if(!tryAnyway && !is(x, "Matrix"))
241 :     return(x)
242 :     ## else
243 :     ok <- canCoerce(x, classes[1])
244 :     while(!ok && length(classes <- classes[-1])) {
245 :     ok <- canCoerce(x, classes[1])
246 :     }
247 :     if(ok) as(x, classes[1]) else x
248 :     }
249 :    
250 : maechler 1174 if(paste(R.version$major, R.version$minor, sep=".") < "2.3")
251 :     ## This will be in R 2.3.0
252 : maechler 973 canCoerce <- function(object, Class) {
253 :     ## Purpose: test if 'object' is coercable to 'Class', i.e.,
254 :     ## as(object, Class) will {typically} work
255 :     ## ----------------------------------------------------------------------
256 :     ## Author: John Chambers, Date: 6 Oct 2005
257 :     is(object, Class) ||
258 :     !is.null(selectMethod("coerce", c(class(object), Class),
259 :     optional = TRUE,
260 :     useInherited = c(from = TRUE, to = FALSE)))
261 :     }
262 :    
263 : maechler 1174 .is.triangular <- function(object, upper = TRUE) {
264 :     ## pretest: is it square?
265 :     d <- dim(object)
266 :     if(d[1] != d[2]) return(FALSE)
267 :     ## else slower test
268 :     if(!is.matrix(object))
269 :     object <- as(object,"matrix")
270 :     ## == 0 even works for logical & complex:
271 :     if(upper)
272 :     all(object[lower.tri(object)] == 0)
273 :     else
274 :     all(object[upper.tri(object)] == 0)
275 :     }
276 :    
277 :     .is.diagonal <- function(object) {
278 :     d <- dim(object)
279 :     if(d[1] != (n <- d[2])) FALSE
280 :     else all(object[rep(c(FALSE, rep.int(TRUE,n)), length = n^2)] == 0)
281 :     }

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