The R Project SVN R

##-- all.equal (..)   emulate  some of  S's functionality
all.equal <- function(target, current, ...) UseMethod("all.equal")

##- all.equal.matrix <- .Alias(all.equal.default)
##- all.equal.array  <- .Alias(all.equal.default)
##-
##- all.equal.expression  <- .Alias(all.equal.language)

all.equal.default <- function(target, current, ...)
{
    if(is.language(target) || is.function(target))
    return(all.equal.language(target, current, ...))
    if(is.recursive(target))
    return(all.equal.list(target, current, ...))
    if(!is.character(msg <- attr.all.equal(target, current, ...))) {
    msg <- NULL
    } else {
    cont <- attr(msg, "continue")
    if(length(cont)==0 || !cont) return(msg)
    }
    new <- if(data.class(target) != data.class(current))
    paste("target is ", data.class(target), ", current is ",
          data.class(current), sep = "") else
    switch(mode(target),
       logical = ,
       numeric   = all.equal.numeric(target, current, ...),
       character = all.equal.character(target, current, ...),
       complex   = all.equal.complex(target, current, ...),
       NULL)
    if(is.character(new)) msg <- c(msg, new)
    if(is.null(msg)) TRUE else msg
}

all.equal.numeric <- function(target, current,
                  tolerance = .Machine$double.eps ^ .5, scale)
{
    lt <- length(target)
    lc <- length(current)
    if(lt != lc)
    return(paste("Numeric: lengths (", lt, ", ", lc, ") differ"), sep = "")
    else msg <- NULL
    target <- as.vector(target)
    current <- as.vector(current)
    out <- is.na(target)
    if(any(out != is.na(current)))
    return(paste("'is.NA' value mismatches:", sum(is.na(current)),
             "in current,", sum(out), " in target"))
    out <- out | (target == current)
    if(all(out)) return(TRUE)
    target <- target[!out]
    current <- current[!out]
    xy <- mean(abs(target - current))
    what <-
    if(missing(scale)) {
        xn <- mean(abs(target))
        if(xn > tolerance) {
        xy <- xy/xn
        "relative"
        } else "absolute"
    } else {
        xy <- xy/scale
        "scaled"
    }
    if(is.na(xy) || xy > tolerance)
    paste("Mean", what, "difference:", format(xy)) else TRUE
}

all.equal.character <- function(target, current, ...)
{
    lt <- length(target)
    lc <- length(current)
    if(lt != lc) {
    msg <- paste("Lengths (", lt, ", ", lc,
             ") differ (string compare on first ", ll <- min(lt, lc),
             ")", sep = "")
    ll <- seq(length = ll)
    target <- target[ll]
    current <- current[ll]
    } else msg <- NULL
    ne <- target != current
    if(!any(ne) && is.null(msg)) TRUE
    else if(any(ne)) c(msg, paste(sum(ne), "string mismatches"))
    else msg
}

all.equal.complex <- function(target, current, tolerance = std.tolerance(), ...)
{
    lt <- length(target)
    lc <- length(current)
    if(lt != lc)
    return(paste("Complex: lengths (", lt, ", ", lc, ") differ", sep = ""))
    out <- is.na(target)
    if(any(out != is.na(current)))
    return(paste(sum(out != is.na(current)), "missing value mismatches"))
    out <- out | (target == current)
    if(all(out)) return(TRUE)
    if(any(out)) {
    target <- target[!out]
    current <- current[!out]
    }
    xy <- if((xn <- mean(Mod(target))) > tolerance)
    mean(Mod(target - current))/xn else mean(Mod(target - current))
    if(xy < tolerance) TRUE else paste("mean Mod difference:", format(xy))
}

all.equal.factor <- function(target, current, ...)
{
    if(!inherits(current, "factor"))
    return("target is factor, but current is not")
    if(!is.character(msg <- attr.all.equal(target, current)))
    msg <- NULL
    else {
    cont <- attr(msg, "continue")
    if(length(cont)==0 || !cont) return(msg)
    }
    class(target) <- class(current) <- NULL
    nax <- is.na(target)
    nay <- is.na(current)
    if(n <- sum(nax != nay))
    msg <- c(msg, paste("NA mismatches:", n))
    else {
    target <- levels(target)[target[!nax]]
    current <- levels(current)[current[!nay]]
    if(is.character(n <- all.equal(target, current)))
        msg <- c(msg, n)
    }
    if(is.null(msg)) TRUE else msg
}

all.equal.formula <- function(target, current, ...)
{
    if(length(target) != length(current))
    return(paste("target, current differ in having response: ",
             length(target) == 3, ", ", length(current) == 3))
    if(all(deparse(target) != deparse(current)))
    "formulas differ in contents"
    else TRUE
}

all.equal.language <- function(target, current, ...)
{
    mt <- mode(target)
    mc <- mode(current)
    if(mt == "expression" && mc == "expression")
    return(all.equal.list(target, current, ...))
    if(mt != mc)
    mmsg <- paste("Modes of target, current: ", mt, ", ", mc,
              sep = "")
    else mmsg <- NULL
    ttxt <- paste(deparse(target), collapse = "\n")
    ctxt <- paste(deparse(current), collapse = "\n")
    msg <- c(mmsg,
         if(ttxt != ctxt) {
         if(pmatch(ttxt, ctxt, FALSE))
             "target a subset of current"
         else if(pmatch(ctxt, ttxt, FALSE))
             "current a subset of target"
         else   "target, current don't match when deparsed"
         } else NULL)
    if(is.null(msg)) TRUE else msg
}

all.equal.list <- function(target, current, ...)
{
    if(!is.character(msg <- attr.all.equal(target, current, ...)))
    msg <- NULL
    nt <- names(target)
    nc <- names(current)
    iseq <-
    if(length(nt)>0 && length(nc)>0) {
        if(any(not.in <- (c.in.t <- match(nc, nt, 0)) == 0))
        msg <- c(msg, paste("Components not in target:",
                    paste(nc[not.in], collapse = ", ")))
        if(any(not.in <- match(nt, nc, 0) == 0))
        msg <- c(msg, paste("Components not in current:",
                    paste(nt[not.in], collapse = ", ")))
        nt[c.in.t]
    } else if(length(target) == length(current)) {
        seq(along = target)
    } else {
        nc <- min(length(target), length(current))
        msg <- c(msg, paste("Length mismatch: comparison on first",
                nc, "components"))
        seq(length = nc)
    }
    for(i in iseq) {
    mi <- all.equal(target[[i]], current[[i]], ...)
    if(is.character(mi))
        msg <- c(msg, paste("Component ", i, ": ", mi, sep=""))
    }
    if(is.null(msg)) TRUE else msg
}


attr.all.equal <- function(target, current, ...)
{
    ##--- "all.equal(.)" for attributes ---
    ##---  Auxiliary in several all.equal(.) methods
    msg <- NULL
    if(mode(target) != mode(current))
    msg <- paste("Modes: ", mode(target), ", ", mode(current), sep = "")
    if(length(target) != length(current))
    msg <- c(msg, paste("Lengths: ", length(target), ", ",
                length(current), sep = ""))
    ax <- attributes(target)
    ay <- attributes(current)
    nx <- names(target)
    ny <- names(current)
    if((lx <- length(nx)) | (ly <- length(ny))) {
    ax$names <- NULL
    ay$names <- NULL
    if(lx && ly) {
        if(is.character(m <- all.equal.character(nx, ny)))
        msg <- c(msg, paste("Names:", m))
    } else if(lx)
        msg <- c(msg, "names for target but not for current")
    else msg <- "names for current but not for target"
    }
    if(length(ax) || length(ay)) {
    nx <- names(ax)
    ny <- names(ay)
    if(length(nx))      ax <- ax[order(nx)]
    if(length(ny))      ay <- ay[order(ny)]
    tt <- all.equal(ax, ay, ...)
    if(is.character(tt)) msg <- c(msg, paste("Attributes: <", tt, ">"))
    }
    if(is.null(msg)) TRUE else structure(msg, continue = TRUE)
}