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 973, Fri Oct 7 20:15:08 2005 UTC revision 1198, Mon Jan 23 15:01:02 2006 UTC
# Line 40  Line 40 
40      h.a <- !identical(nullDN, dna <- dimnames(a))      h.a <- !identical(nullDN, dna <- dimnames(a))
41      h.b <- !identical(nullDN, dnb <- dimnames(b))      h.b <- !identical(nullDN, dnb <- dimnames(b))
42      if(h.a || h.b) {      if(h.a || h.b) {
43          if (!h.b) h.a          if (!h.b) dna
44          else if(!h.a) h.b          else if(!h.a) dnb
45          else { ## both have non-trivial dimnames          else { ## both have non-trivial dimnames
46              r <- dna # "default" result              r <- dna # "default" result
47              for(j in 1:2) {              for(j in 1:2) {
# Line 215  Line 215 
215      stopifnot(is(from, "lMatrix"))      stopifnot(is(from, "lMatrix"))
216      fixupDense(new(sub("^l", "d", class(from)),      fixupDense(new(sub("^l", "d", class(from)),
217                     x = as.double(from@x),                     x = as.double(from@x),
218                     Dim = from@Dim, Dimnames = from@Dimnames,                     Dim = from@Dim, Dimnames = from@Dimnames),
                    factors = list()), ## FIXME: treat 'factors' smartly  
219                 from)                 from)
220        ## FIXME: treat 'factors' smartly {not for triangular!}
221  }  }
222    
223  if(FALSE)# unused  if(FALSE)# unused
# Line 230  Line 230 
230  d2l_Matrix <- function(from) {  d2l_Matrix <- function(from) {
231      stopifnot(is(from, "dMatrix"))      stopifnot(is(from, "dMatrix"))
232      fixupDense(new(sub("^d", "l", class(from)),      fixupDense(new(sub("^d", "l", class(from)),
233                     Dim = from@Dim, Dimnames = from@Dimnames,                     Dim = from@Dim, Dimnames = from@Dimnames),
                    factors = list()), ## FIXME: treat 'factors' smartly  
234                 from)                 from)
235        ## FIXME: treat 'factors' smartly {not for triangular!}
236  }  }
237    
238    
# Line 247  Line 247 
247      if(ok) as(x, classes[1]) else x      if(ok) as(x, classes[1]) else x
248  }  }
249    
250  ## MM thinks the following should become part of 'methods' :  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) {  canCoerce <- function(object, Class) {
253    ## Purpose:  test if 'object' is coercable to 'Class', i.e.,    ## Purpose:  test if 'object' is coercable to 'Class', i.e.,
254    ##           as(object, Class) will {typically} work    ##           as(object, Class) will {typically} work
# Line 259  Line 260 
260                           useInherited = c(from = TRUE, to = FALSE)))                           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.973  
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