testVectorFunctionality <- function(from.numeric=paste("as.", CLASS, sep=""),
                                    CLASS="numeric",
                                    generatorFun=generic.generator(from.numeric),
                                    len.gen=c(3,10),
                                    level=c("bonus", "basic", "extra"),
                                    verbose=TRUE) {
    ##
    ## from.numeric should be a function that takes a numeric vector ii
    ## and returns a vector of the desired class with the same length
    ## as ii, and elements should be unique for different values in ii.
    ##
    ## Only one of from.numeric and CLASS need be supplied.
    ##
    ## len.gen is the length of the vectors to be tested, in addition
    ## to vectors of length 0 and 1.
    ##
    ## level is the group of functions to test.
    ##
    ## generatorFun is a function that takes a vector of lengths and
    ## returns a list of vectors of the supplied lengths, with no elements
    ## duplicated among any vectors.  This argument usually need not
    ## be supplied, but if it is, from.numeric and CLASS are ignored.
    ##
    level <- match.arg(level)
    ##
    ## Levels:
    ## basic: c(x), length(x) and x[i]
    ## extra: x[i]<-value, rep(), unique(), duplicated(), ...
    ## bonus: head(), tail(), sort(), ...
    ## (where could character coercion functions fit in? as.character(), and as.<CLASSNAME>())
    ## (where could NA operations fit in? is.na() x[...] <- NA)
    runTest <- function(e1, e2, bindings, what, verbose=TRUE) {
        e1.expr <- substitute(e1)
        e2.expr <- substitute(e2)
        e1.res <- try(eval(e1.expr, bindings), silent=TRUE)
        e2.res <- try(eval(e2.expr, bindings), silent=TRUE)
        e1.text <- deparse(e1.expr)
        e2.text <- deparse(e2.expr)
        if (is(e1.res, "try-error")) {
            if (verbose) {
                cat("  Error evaluating e1:", if (length(e1.text)>1) "\n ", " ",
                    paste(e1.text, "\n", sep=""), sep="")
                cat(paste("   ", as.character(e1.res)), sep="\n")
            }
            return(list(error=what))
        }
        if (is(e2.res, "try-error")) {
            if (verbose) {
                cat("  Error evaluating e2:", if (length(e2.text)>1) "\n ", " ",
                    paste(e2.text, "\n", sep=""), sep="")
                cat(paste("   ", as.character(e2.res)), sep="\n")
            }
            return(list(error=what))
        }
        if (identical(e1.res, e2.res)) {
            return(list(ok=what))
        } else {
            multiline <- length(e1.text)>1 || length(e2.text)>1
            if (verbose) {
                cat("  Failed consistency check:", if (multiline) "\n" else " ",
                    paste(if (multiline) "  ", e1.text, if (multiline) "\n", sep=""),
                    if (multiline) "==\n" else " == ",
                    paste(if (multiline) "  ", e2.text, "\n", sep=""), sep="")
            }
            if (verbose>1) {
                cat("    LHS=", deparse(do.call("substitute", list(e1.expr, bindings))), "\n", sep="")
                cat("    RHS=", deparse(do.call("substitute", list(e2.expr, bindings))), "\n", sep="")
            }
            return(list(failure=what))
        }
    }
    summarizeTests <- function(res, level, class.name) {
        if (length(res)==0) {
            cat("Did not perform any ", level, " consistency tests on ", class.name, "\n", sep="")
        } else {
            total.tab <- table(names(res))
            cat("In ", length(res), " ", level, " consistency tests on ", class.name, ", had the following outcomes: ",
                paste(names(total.tab), ":", total.tab, "", collapse=", ", sep=""), "\n", sep="")
            for (status in names(total.tab)) {
                func.tab <- table(unlist(res[names(res)==status], use.names=FALSE))
                func.names <- ifelse(regexpr("^[\\.A-Za-z_0-9]*$", names(func.tab))<1,
                                     paste("'", names(func.tab), "'", sep=""), names(func.tab))
                cat("  '", status, "' tests (", total.tab[status], ") involved: ",
                    paste(func.names, ":", func.tab, "", collapse=", ", sep=""), "\n", sep="")
            }
        }
    }
    ## Make len.gen at least length 2, make sure it starts with a number >=2,
    ## and give it names like xa.len, xb.len, etc.
    if (length(len.gen) && len.gen[1] < 2)
        len.gen <- c(2, len.gen)
    if (length(len.gen) < 2)
        len.gen <- sort(c(len.gen, setdiff(c(3,10), len.gen))[1:2])
    if (length(len.gen) > length(letters))
        len.gen <- len.gen[seq(along=letters)]
    names(len.gen) <- paste("x", letters[seq(along=len.gen)], ".len", sep="")
    len.gen <- c(x0.len=0L, x1.len=1L, len.gen)
    storage.mode(len.gen) <- "integer"
    ## Create the vectors, and name them
    vecList <- generatorFun(lengths=len.gen)
    names(vecList) <- sub(".len", "", names(len.gen))
    ## Put vectors and lengths in a named list
    bindings <- c(vecList, as.list(len.gen))
    class.name <- paste("'", class(vecList[[1]]), "'", sep="", collapse=", ")
    if (length(class(vecList[[1]]))>1)
        class.name <- paste("[", class.name, "]", sep="")

    ### The tests ###
    ## Note that all test results are checked with identical(), so care must be
    ## taken in specifying tests.
    ##
    ## basic: c(x), length(x) and x[i]
    if (verbose)
        cat("Testing basic vector functionality for class ", class.name, "\n", sep="")
    basic.res <-
        list(runTest(length(x1), 1L, bindings, "length", verbose),
             runTest(length(x0), 0L, bindings, "length", verbose),
             runTest(length(xa), xa.len, bindings, "length", verbose),
             runTest(length(xb), xb.len, bindings, "length", verbose),
             runTest(length(c(x1,xa)), xa.len+x1.len, bindings, c("c", "length"), verbose),
             runTest(length(c(x0,xa)), xa.len, bindings, c("c", "length"), verbose),
             runTest(c(x1), x1, bindings, c("c"), verbose),
             runTest(c(x1,x0), x1, bindings, c("c"), verbose),
             runTest(c(x0,x1), x1, bindings, c("c"), verbose),
             runTest(c(xa), xa, bindings, c("c"), verbose),
             runTest(c(xa,x0), xa, bindings, c("c"), verbose),
             runTest(c(x0,xa), xa, bindings, c("c"), verbose),
             runTest(x1, x1[1], bindings, c("["), verbose),
             runTest(xa, xa[seq(len=xa.len)], bindings, "[", verbose),
             runTest(length(c(xa,xb)), xa.len + xb.len, bindings, c("c", "length"), verbose),
             runTest(xa[-length(xa)], xa[seq(len=xa.len-1)], bindings, c("[", "length"), verbose),
             runTest(length(xa[0]), 0L, bindings, c("[", "length"), verbose)
             )
    basic.res <- unlist(basic.res, use.names=TRUE, recursive=FALSE)

    ## extra: x[i]<-value, rep(), unique(), duplicated(), ...
    if (all(names(basic.res)=="ok") && is.element(level, c("extra", "bonus"))) {
        if (verbose)
            cat("Testing extra vector functionality for class ", class.name, "\n", sep="")
        ## add another vector, with duplications, to the bindings
        bindings <- c(bindings, list(xA=bquote(.(c(xa,x1,xb,xa,x1)), bindings)))
        extra.res <-
            list(runTest(unique(xa), xa, bindings, "unique", verbose),
                 runTest(unique(xb), xb, bindings, "unique", verbose),
                 runTest(unique(x0), x0, bindings, "unique", verbose),
                 runTest(unique(x1), x1, bindings, "unique", verbose),
                 runTest(duplicated(x0), logical(0), bindings, "duplicated", verbose),
                 runTest(any(duplicated(x1)), FALSE, bindings, "duplicated", verbose),
                 runTest(any(duplicated(xa)), FALSE, bindings, "duplicated", verbose),
                 runTest(any(duplicated(xb)), FALSE, bindings, "duplicated", verbose),
                 runTest(unique(xA), xA[!duplicated(xA)], bindings, c("unique", "duplicated"), verbose),
                 runTest(duplicated(c(xa,xa)), c(rep(FALSE,xa.len), rep(TRUE,xa.len)), bindings, "duplicated", verbose),
                 runTest(rep(x1, 3), c(x1,x1,x1), bindings, "rep", verbose),
                 runTest(rep(xa, 3), c(xa,xa,xa), bindings, "rep", verbose),
                 runTest(rep(xb, 2), c(xb,xb), bindings, "rep", verbose),
                 runTest(rep(x1, 0), x1[0], bindings, "rep", verbose),
                 runTest(rep(xa, each=3), xa[rep(seq(len=xa.len), each=3)], bindings, "rep", verbose),
                 runTest(rep(xb, each=2), xb[rep(seq(len=xb.len), each=2)], bindings, "rep", verbose),
                 runTest(rep(xa, length.out=xa.len+1), c(xa, xa[1]), bindings, "rep", verbose)
                 )
        extra.res <- unlist(extra.res, use.names=TRUE, recursive=FALSE)
    } else {
        extra.res <- list()
    }

    ## bonus: head(), tail(), sort(), ...
    if (all(names(basic.res)=="ok") && all(names(extra.res)=="ok") && is.element(level, c("bonus"))) {
        if (verbose)
            cat("Testing bonus vector functionality for class ", class.name, "\n", sep="")
        bonus.res <-
            list(runTest(sort(c(x1,xa,xb)), sort(c(xb,x1,xa)), bindings, "sort", verbose),
                 runTest(head(xa, 2), xa[seq(len=2)], bindings, "head", verbose),
                 runTest(head(xb, 3), xb[seq(len=min(3,xb.len))], bindings, "head", verbose),
                 runTest(tail(xa, 2), xa[seq(len=2, to=xa.len)], bindings, "tail", verbose),
                 runTest(tail(xb, 3), xb[seq(len=min(3,xb.len), to=xb.len)], bindings, "tail", verbose)
                 )
        bonus.res <- unlist(bonus.res, use.names=TRUE, recursive=FALSE)
    } else {
        bonus.res <- list()
    }

    if (verbose) {
        summarizeTests(basic.res, "basic", class.name)
        summarizeTests(extra.res, "extra", class.name)
        summarizeTests(bonus.res, "bonus", class.name)
    } else {
        if (all(c(names(basic.res), names(extra.res), names(bonus.res))=="ok"))
            cat("Passed all ", length(basic.res), " basic tests, ",
                length(extra.res), " extra tests, and ", 
                length(bonus.res), " bonus tests\n", sep="")
        else
            cat("Failed ", sum(names(basic.res)!="ok"), " of ", length(basic.res), " basic tests, ",
                sum(names(extra.res)!="ok"), " of ", length(extra.res), " extra tests, and ",
                sum(names(bonus.res)!="ok"), " of ", length(bonus.res), " bonus tests\n", sep="")
    }
    
    return(invisible(list(basic.res=basic.res, extra.res=extra.res, bonus.res=bonus.res, bindings=bindings)))
}

generic.generator <- function(as.CLASS.numeric) {
    if (!is.function(as.CLASS.numeric))
        as.CLASS.numeric <- get(as.CLASS.numeric, mode="function")
    function (lengths)
        mapply(lengths, cumsum(lengths), FUN=function(len, end) as.CLASS.numeric(seq(to=end, len=len)), SIMPLIFY=FALSE)
}
