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 954, Wed Sep 28 19:34:31 2005 UTC revision 1198, Mon Jan 23 15:01:02 2006 UTC
# Line 34  Line 34 
34      da      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) {  rowCheck <- function(a, b) {
64      da <- dim(a)      da <- dim(a)
65      db <- dim(b)      db <- dim(b)
# Line 56  Line 82 
82      da[2]      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"),  prTriang <- function(x, digits = getOption("digits"),
94                       justify = "none", right = TRUE)                       justify = "none", right = TRUE)
# Line 166  Line 199 
199      # and keep x@diag      # and keep x@diag
200      x      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.954  
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