SCM

SCM Repository

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

Diff of /pkg/Matrix/R/Auxiliaries.R

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

revision 3019, Sat Oct 11 20:51:53 2014 UTC revision 3020, Tue Oct 14 16:14:02 2014 UTC
# Line 294  Line 294 
294      ca      ca
295  }  }
296    
297  dimNamesCheck <- function(a, b) {  ##' Constructs "sensical" dimnames for something like  a + b ;
298      ## Constructs "sensical" dimnames for something like  a + b ;  ##' assume dimCheck() has happened before
299      ## assume dimCheck() has happened before  ##'
300    ##' NOTA BENE:   R's  ?Arithmetic  says
301    ##' ---------
302    ##'>  For arrays (and an array result) the dimensions and dimnames are taken from
303    ##'>  first argument if it is an array, otherwise the second.
304    ##' but that's not quite correct:
305    ##' The dimnames are taken from second *if* the first are NULL.
306    ##'
307    ##' @title Construct dimnames for  a  o  b
308    ##' @param a matrix
309    ##' @param b matrix
310    ##' @param useFirst logical indicating if dimnames(a), the first, is taken, unless NULL
311    ##' @param check logical indicating if a warning should be signalled for mismatches
312    ##' @return a \code{\link{list}} of length two with dimnames
313    ##' @author Martin Maechler
314    dimNamesCheck <- function(a, b, useFirst = TRUE, check = FALSE) {
315      nullDN <- list(NULL,NULL)      nullDN <- list(NULL,NULL)
316      h.a <- !identical(nullDN, dna <- dimnames(a))      h.a <- !identical(nullDN, dna <- dimnames(a))
317      h.b <- !identical(nullDN, dnb <- dimnames(b))      h.b <- !identical(nullDN, dnb <- dimnames(b))
318      if(h.a || h.b) {      if(h.a || h.b) {
319            if(useFirst) {
320                if(!h.a) dnb else dna
321            } else {
322          if (!h.b) dna          if (!h.b) dna
323          else if(!h.a) dnb          else if(!h.a) dnb
324          else { ## both have non-trivial dimnames          else { ## both have non-trivial dimnames
# Line 308  Line 326 
326              for(j in 1:2) if(!is.null(dn <- dnb[[j]])) {              for(j in 1:2) if(!is.null(dn <- dnb[[j]])) {
327                  if(is.null(r[[j]]))                  if(is.null(r[[j]]))
328                      r[[j]] <- dn                      r[[j]] <- dn
329                  else if(!identical(r[[j]], dn))                      else if(check && !identical(r[[j]], dn))
330                      warning(gettextf("dimnames [%d] mismatch in %s", j,                      warning(gettextf("dimnames [%d] mismatch in %s", j,
331                                       deparse(sys.call(sys.parent()))),                                       deparse(sys.call(sys.parent()))),
332                              call. = FALSE, domain=NA)                              call. = FALSE, domain=NA)
# Line 316  Line 334 
334              r              r
335          }          }
336      }      }
337        }
338      else      else
339          nullDN          nullDN
340  }  }
341    
342    ##' @title Symmetrize dimnames(.)
343    ##' @param x a square matrix
344    ##' @param col logical indicating if the column names should be taken when
345    ##' both are non-NULL.
346    ##' @param names logical indicating if the names(dimnames(.)) should be
347    ##' symmetrized and kept *if* they differ.
348    ##' @return a matrix like \code{x}, say \code{r}, with dimnames fulfilling
349    ##'             dr <- dimnames(r); identical(dr[1], dr[2])
350    ##' @author Martin Maechler
351    symmetrizeDimnames <- function(x, col=TRUE, names=TRUE) {
352        dimnames(x) <- symmDN(dimnames(x), col=col, names=names)
353        x
354    }
355    
356    symmDN <- function(dn, col=TRUE, names=TRUE) {
357        if(is.null(dn) || identical(dn[1L], dn[2L]))
358            return(dn)
359        J <-
360            if(col) {
361                if(is.null(dn[[2L]])) 1L else 2L
362            } else { ## !col : row
363                if(is.null(dn[[1L]])) 2L else 1L
364            }
365    
366        if(!is.null(n <- names(dn))) {
367            if(length(n) != 2)
368                stop("names(dimnames(<matrix>)) must be NULL or of length two")
369            if(n[1L] != n[2L])
370                names(dn) <- if(names) n[c(J,J)] # else NULL
371        }
372        dn[c(J,J)]
373    }
374    
375  rowCheck <- function(a, b) {  rowCheck <- function(a, b) {
376      da <- dim(a)      da <- dim(a)
377      db <- dim(b)      db <- dim(b)
# Line 408  Line 460 
460  }  }
461    
462    
463    
464  ## The i-th unit vector  e[1:n] with e[j] = \delta_{i,j}  ## The i-th unit vector  e[1:n] with e[j] = \delta_{i,j}
465  ## .E.i.log <- function(i,n)  i == (1:n)  ## .E.i.log <- function(i,n)  i == (1:n)
466  ## .E.i <- function(i,n)  ## .E.i <- function(i,n)

Legend:
Removed from v.3019  
changed lines
  Added in v.3020

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge