SCM

SCM Repository

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

Diff of /pkg/R/Auxiliaries.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 632, Sun Mar 13 21:00:53 2005 UTC revision 1198, Mon Jan 23 15:01:02 2006 UTC
# Line 1  Line 1 
1  #### "Namespace private" Auxiliaries  such as method functions  #### "Namespace private" Auxiliaries  such as method functions
2  #### (called from more than one place --> need to be defined early)  #### (called from more than one place --> need to be defined early)
3    
4  ## For %*% (M = Matrix; n = numeric):  ## For %*% (M = Matrix; v = vector (double or integer {complex maybe?}):
5  .M.n <- function(x, y) callGeneric(x, as.matrix(y))  .M.v <- function(x, y) callGeneric(x, as.matrix(y))
6  .n.M <- function(x, y) callGeneric(rbind(x), y)  .v.M <- function(x, y) callGeneric(rbind(x), y)
7    
8    .has.DN <- ## has non-trivial Dimnames slot?
9        function(x) !identical(list(NULL,NULL), x@Dimnames)
10    
11    .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  ## chol() via "dpoMatrix"  ## chol() via "dpoMatrix"
21  cholMat <- function(x, pivot, LINPACK) {  cholMat <- function(x, pivot, LINPACK) {
22      px <- as(x, "dpoMatrix")      px <- as(x, "dpoMatrix")
23      if(identical(TRUE, validObject(px, test=TRUE)))      if (isTRUE(validObject(px, test=TRUE))) chol(px)
         chol(px)  
24      else stop("'x' is not positive definite -- chol() undefined.")      else stop("'x' is not positive definite -- chol() undefined.")
25  }  }
26    
27    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    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            if (!h.b) dna
44            else if(!h.a) dnb
45            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    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    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    
93    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        if(is(x, "TsparseMatrix"))
142            return(unique(cbind(x@i,x@j)))
143    
144        isCol <- function(M) any("i" == slotNames(M))
145        .Call("compressed_non_0_ij", x, isCol(x), PACKAGE = "Matrix")
146    }
147    
148    ### There is a test on this in ../tests/dgTMatrix.R !
149    uniq <- function(x) {
150        if(is(x, "TsparseMatrix")) {
151            ## 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    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    
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                       Dim = from@Dim, Dimnames = from@Dimnames),
219                   from)
220        ## FIXME: treat 'factors' smartly {not for triangular!}
221    }
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                       Dim = from@Dim, Dimnames = from@Dimnames),
234                   from)
235        ## FIXME: treat 'factors' smartly {not for triangular!}
236    }
237    
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    if(paste(R.version$major, R.version$minor, sep=".") < "2.3")
251        ## This will be in R 2.3.0
252    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    .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    }

Legend:
Removed from v.632  
changed lines
  Added in v.1198

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