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 919 - (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 632 ## chol() via "dpoMatrix"
12 :     cholMat <- function(x, pivot, LINPACK) {
13 :     px <- as(x, "dpoMatrix")
14 : bates 703 if (isTRUE(validObject(px, test=TRUE))) chol(px)
15 : maechler 632 else stop("'x' is not positive definite -- chol() undefined.")
16 :     }
17 : maechler 908
18 :     rowCheck <- function(a, b) {
19 :     da <- dim(a)
20 :     db <- dim(b)
21 :     if(da[1] != db[1])
22 :     stop(gettextf("Matrices must have same number of rows in %s",
23 :     deparse(sys.call(sys.parent()))),
24 :     call. = FALSE)
25 :     ## return the common nrow()
26 :     da[1]
27 :     }
28 :    
29 :     colCheck <- function(a, b) {
30 :     da <- dim(a)
31 :     db <- dim(b)
32 :     if(da[2] != db[2])
33 :     stop(gettextf("Matrices must have same number of columns in %s",
34 :     deparse(sys.call(sys.parent()))),
35 :     call. = FALSE)
36 :     ## return the common ncol()
37 :     da[2]
38 :     }
39 :    
40 :    
41 : maechler 919 prTriang <- function(x, digits = getOption("digits"),
42 :     justify = "none", right = TRUE)
43 :     {
44 :     ## modeled along stats:::print.dist
45 :     diag <- TRUE
46 :     upper <- x@uplo == "U"
47 :    
48 :     m <- as(x, "matrix")
49 :     cf <- format(m, digits = digits, justify = justify)
50 :     if(upper)
51 :     cf[row(cf) > col(cf)] <- "."
52 :     else
53 :     cf[row(cf) < col(cf)] <- "."
54 :     print(cf, quote = FALSE, right = right)
55 :     invisible(x)
56 :     }
57 :    
58 :     prMatrix <- function(x, digits = getOption("digits")) {
59 :     d <- dim(x)
60 :     cl <- class(x)
61 :     cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
62 :     maxp <- getOption("max.print")
63 :     if(prod(d) <= maxp) {
64 :     if(is(x, "triangularMatrix"))
65 :     prTriang(x, digits = digits)
66 :     else
67 :     print(as(x, "matrix"), digits = digits)
68 :     }
69 :     else { ## d[1] > maxp / d[2] >= nr :
70 :     m <- as(x, "matrix")
71 :     nr <- maxp %/% d[2]
72 :     n2 <- ceiling(nr / 2)
73 :     print(head(m, max(1, n2)))
74 :     cat("\n ..........\n\n")
75 :     print(tail(m, max(1, nr - n2)))
76 :     }
77 :     ## DEBUG: cat("str(.):\n") ; str(x)
78 :     invisible(x)# as print() S3 methods do
79 :     }
80 :    
81 :     ## For sparseness handling
82 :     non0ind <- function(x) {
83 :     if(is.numeric(x))
84 :     return(if((n <- length(x))) (0:(n-1))[x != 0] else integer(0))
85 :    
86 :     ## else return a (i,j) matrix of non-zero-indices
87 :    
88 :     stopifnot(is(x, "sparseMatrix"))
89 :     if(is(x, "gTMatrix"))
90 :     stop("'x' must be column- or row-compressed 'sparseMatrix'")
91 :     isCol <- function(M) any("i" == slotNames(M))
92 :     .Call("compressed_non_0_ij", x, isCol(x), PACKAGE = "Matrix")
93 :     }
94 :    
95 :     ### These are currently tests in ../tests/dgTMatrix.R !!!
96 :     uniq <- function(x) {
97 :     if(is(x, "gTMatrix")) {
98 :     ## Purpose: produce a *unique* triplet representation:
99 :     ## by having (i,j) sorted and unique
100 :     ## -----------------------------------------------------------
101 :     ## The following is *not* efficient {but easy to program}:
102 :     if(is(x, "dgTMatrix")) as(as(x, "dgCMatrix"), "dgTMatrix")
103 :     else if(is(x, "lgTMatrix")) as(as(x, "lgCMatrix"), "lgTMatrix")
104 :     else stop("not implemented for class", class(x))
105 :    
106 :     } else x # not 'gT' ; i.e. "uniquely" represented in any case
107 :     }
108 :    
109 :     if(FALSE) ## try an "efficient" version
110 :     uniq_gT <- function(x)
111 :     {
112 :     ## Purpose: produce a *unique* triplet representation:
113 :     ## by having (i,j) sorted and unique
114 :     ## ----------------------------------------------------------------------
115 :     ## Arguments: a "gT" Matrix
116 :     stopifnot(is(x, "gTMatrix"))
117 :     if((n <- length(x@i)) == 0) return(x)
118 :     ii <- order(x@i, x@j)
119 :     if(any(ii != 1:n)) {
120 :     x@i <- x@i[ii]
121 :     x@j <- x@j[ii]
122 :     x@x <- x@x[ii]
123 :     }
124 :     ij <- x@i + nrow(x) * x@j
125 :     if(any(dup <- duplicated(ij))) {
126 :    
127 :     }
128 :     ### We should use a .Call() based utility for this!
129 :    
130 :     }
131 :    

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