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 954 - (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 908 rowCheck <- function(a, b) {
38 :     da <- dim(a)
39 :     db <- dim(b)
40 :     if(da[1] != db[1])
41 :     stop(gettextf("Matrices must have same number of rows in %s",
42 :     deparse(sys.call(sys.parent()))),
43 :     call. = FALSE)
44 :     ## return the common nrow()
45 :     da[1]
46 :     }
47 :    
48 :     colCheck <- function(a, b) {
49 :     da <- dim(a)
50 :     db <- dim(b)
51 :     if(da[2] != db[2])
52 :     stop(gettextf("Matrices must have same number of columns in %s",
53 :     deparse(sys.call(sys.parent()))),
54 :     call. = FALSE)
55 :     ## return the common ncol()
56 :     da[2]
57 :     }
58 :    
59 :    
60 : maechler 919 prTriang <- function(x, digits = getOption("digits"),
61 :     justify = "none", right = TRUE)
62 :     {
63 :     ## modeled along stats:::print.dist
64 :     diag <- TRUE
65 :     upper <- x@uplo == "U"
66 :    
67 :     m <- as(x, "matrix")
68 :     cf <- format(m, digits = digits, justify = justify)
69 :     if(upper)
70 :     cf[row(cf) > col(cf)] <- "."
71 :     else
72 :     cf[row(cf) < col(cf)] <- "."
73 :     print(cf, quote = FALSE, right = right)
74 :     invisible(x)
75 :     }
76 :    
77 :     prMatrix <- function(x, digits = getOption("digits")) {
78 :     d <- dim(x)
79 :     cl <- class(x)
80 :     cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
81 :     maxp <- getOption("max.print")
82 :     if(prod(d) <= maxp) {
83 :     if(is(x, "triangularMatrix"))
84 :     prTriang(x, digits = digits)
85 :     else
86 :     print(as(x, "matrix"), digits = digits)
87 :     }
88 :     else { ## d[1] > maxp / d[2] >= nr :
89 :     m <- as(x, "matrix")
90 :     nr <- maxp %/% d[2]
91 :     n2 <- ceiling(nr / 2)
92 :     print(head(m, max(1, n2)))
93 :     cat("\n ..........\n\n")
94 :     print(tail(m, max(1, nr - n2)))
95 :     }
96 :     ## DEBUG: cat("str(.):\n") ; str(x)
97 :     invisible(x)# as print() S3 methods do
98 :     }
99 :    
100 :     ## For sparseness handling
101 :     non0ind <- function(x) {
102 :     if(is.numeric(x))
103 :     return(if((n <- length(x))) (0:(n-1))[x != 0] else integer(0))
104 :    
105 :     ## else return a (i,j) matrix of non-zero-indices
106 :    
107 :     stopifnot(is(x, "sparseMatrix"))
108 : maechler 925 if(is(x, "TsparseMatrix"))
109 : maechler 954 return(unique(cbind(x@i,x@j)))
110 :    
111 : maechler 919 isCol <- function(M) any("i" == slotNames(M))
112 :     .Call("compressed_non_0_ij", x, isCol(x), PACKAGE = "Matrix")
113 :     }
114 :    
115 : maechler 925 ### There is a test on this in ../tests/dgTMatrix.R !
116 : maechler 919 uniq <- function(x) {
117 : maechler 925 if(is(x, "TsparseMatrix")) {
118 : maechler 919 ## Purpose: produce a *unique* triplet representation:
119 :     ## by having (i,j) sorted and unique
120 :     ## -----------------------------------------------------------
121 :     ## The following is *not* efficient {but easy to program}:
122 :     if(is(x, "dgTMatrix")) as(as(x, "dgCMatrix"), "dgTMatrix")
123 :     else if(is(x, "lgTMatrix")) as(as(x, "lgCMatrix"), "lgTMatrix")
124 :     else stop("not implemented for class", class(x))
125 :    
126 :     } else x # not 'gT' ; i.e. "uniquely" represented in any case
127 :     }
128 :    
129 :     if(FALSE) ## try an "efficient" version
130 :     uniq_gT <- function(x)
131 :     {
132 :     ## Purpose: produce a *unique* triplet representation:
133 :     ## by having (i,j) sorted and unique
134 :     ## ----------------------------------------------------------------------
135 :     ## Arguments: a "gT" Matrix
136 :     stopifnot(is(x, "gTMatrix"))
137 :     if((n <- length(x@i)) == 0) return(x)
138 :     ii <- order(x@i, x@j)
139 :     if(any(ii != 1:n)) {
140 :     x@i <- x@i[ii]
141 :     x@j <- x@j[ii]
142 :     x@x <- x@x[ii]
143 :     }
144 :     ij <- x@i + nrow(x) * x@j
145 :     if(any(dup <- duplicated(ij))) {
146 :    
147 :     }
148 :     ### We should use a .Call() based utility for this!
149 :    
150 :     }
151 :    
152 : maechler 946 t_geMatrix <- function(x) {
153 :     x@x <- as.vector(t(array(x@x, dim = x@Dim))) # no dimnames here
154 :     x@Dim <- x@Dim[2:1]
155 :     x@Dimnames <- x@Dimnames[2:1]
156 :     ## FIXME: how to set factors?
157 :     x
158 :     }
159 :    
160 :     ## t( [dl]trMatrix ) and t( [dl]syMatrix ) :
161 :     t_trMatrix <- function(x) {
162 :     x@x <- as.vector(t(as(x, "matrix")))
163 :     x@Dim <- x@Dim[2:1]
164 :     x@Dimnames <- x@Dimnames[2:1]
165 :     x@uplo <- if (x@uplo == "U") "L" else "U"
166 :     # and keep x@diag
167 :     x
168 :     }

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