##-- 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)
}