Moving on from the discussion of the fact that length(x)==9 for any
POSIXlt object x (which seems diabolically confusing, given that 'c' and
'[' are defined for POSIXlt and have the vector-like behavior one would
expect), what about having some guidelines for coding and documentation
of vector-like classes?
(1) a vector-like class should implement functions in groups:
level 1: 'c', '[', 'length'
level 2: 'x[i] <- value', 'rep', 'unique', 'duplicated'
level 3: 'head', 'tail', 'sort'
NA group: 'is.na' 'x[i] <- NA' 'is.na(x) <- TRUE'
character coercion: 'as.character', 'as.<CLASS>.character'
names group: 'names()' 'names()<-'
[should '==', 'all.equal' be included anywhere]
If any member of a group is implemented, then it is considered good
style to implement the others.
(2) conformance or deviation from this guideline should be documented on
the help page for the class.
These could go in a section of R-ext, and a function that automatically
checks conformance could also be supplied as part of R. A rough version
of such a function is attached.
This would have the following benefits:
(1) developers would have guidelines and tools to help them write
classes that behave in a way that users expect
(2) users would know better what to expect, both in general, and in
specific cases where developers followed the documentation guidelines.
(3) observance of the guidelines would be an indicator of software
quality (no evidence of any attention to the guidelines would be a sign
that the code was more of an experiment than a piece of software that
was carefully engineered for widespread use.)
All of the above is a rough draft that could be discussed further (e.g.,
should '[.<-' go in level 1 or level 2?) if there was any interest in
pursuing this suggestion.
Comments?
-- Tony Plate
PS:
Here's a few examples of running an automatic vector-functionality
tester on some vector-like classes in R ("basic"="level 1",
"extra"="level 2", and "bonus"="level 3" functions) (this might be hard
to read if line wrapping happens -- I've attached text files):
> source("testVectorFunctionality.R")
> library(chron)
> if (exists("length.POSIXlt")) remove(list="length.POSIXlt")
>
> ### 'character' passes the functionality tests
> res <- testVectorFunctionality(CLASS="character", verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### 'numeric' passes the functionality tests
> res <- testVectorFunctionality(CLASS="numeric", verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### 'integer' passes the functionality tests
> res <- testVectorFunctionality(CLASS="integer", verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### 'Date' passes the functionality tests
> res <- testVectorFunctionality(from.numeric=function(i)
as.Date("2001/01/01") + i, verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### chron 'times' passes the basic, but not the extra functionality tests
> res <- testVectorFunctionality(from.numeric=function(i)
chron(times=i), verbose=FALSE)
Failed 0 of 17 basic tests, 12 of 17 extra tests, and 0 of 0 bonus tests
> res <- testVectorFunctionality(from.numeric=function(i)
chron(times=i), verbose=TRUE)
Testing basic vector functionality for class 'times'
Testing extra vector functionality for class 'times'
Failed consistency check: unique(xa) == xa
Failed consistency check: unique(xb) == xb
Failed consistency check: unique(x0) == x0
Failed consistency check: unique(x1) == x1
Failed consistency check: unique(xA) == xA[!duplicated(xA)]
Failed consistency check: rep(x1, 3) == c(x1, x1, x1)
Failed consistency check: rep(xa, 3) == c(xa, xa, xa)
Failed consistency check: rep(xb, 2) == c(xb, xb)
Failed consistency check: rep(x1, 0) == x1[0]
Failed consistency check: rep(xa, each = 3) == xa[rep(seq(len =
xa.len), each = 3)]
Failed consistency check: rep(xb, each = 2) == xb[rep(seq(len =
xb.len), each = 2)]
Failed consistency check: rep(xa, length.out = xa.len + 1) == c(xa,
xa[1])
In 17 basic consistency tests on 'times', had the following outcomes: ok:17
'ok' tests (17) involved: '[':4, c:9, length:9
In 17 extra consistency tests on 'times', had the following outcomes:
failure:12, ok:5
'failure' tests (12) involved: duplicated:1, rep:7, unique:5
'ok' tests (5) involved: duplicated:5
Did not perform any bonus consistency tests on 'times'
>
> ### chron 'dates' does not pass the basic functionality tests
> res <- testVectorFunctionality(from.numeric=function(i) chron(i),
verbose=FALSE)
Failed 6 of 17 basic tests, 0 of 0 extra tests, and 0 of 0 bonus tests
> res <- testVectorFunctionality(from.numeric=function(i) chron(i),
verbose=TRUE)
Testing basic vector functionality for class ['dates', 'times']
Failed consistency check: c(x1) == x1
Failed consistency check: c(x1, x0) == x1
Failed consistency check: c(x0, x1) == x1
Failed consistency check: c(xa) == xa
Failed consistency check: c(xa, x0) == xa
Failed consistency check: c(x0, xa) == xa
In 17 basic consistency tests on ['dates', 'times'], had the following
outcomes: failure:6, ok:11
'failure' tests (6) involved: c:6
'ok' tests (11) involved: '[':4, c:3, length:9
Did not perform any extra consistency tests on ['dates', 'times']
Did not perform any bonus consistency tests on ['dates', 'times']
> # The reason for the failure with c() is that it removes names on the
origin in chron 'dates'
> eval(quote(all.equal(c(x1), x1)), res$bindings)
[1] "Attributes: < Component 3: names for current but not for target >"
> attr(eval(quote(x1), res$bindings), "origin")
month day year
1 1 1970
> attr(eval(quote(c(x1)), res$bindings), "origin")
[1] 1 1 1970
>
> ### POSIXct passes the functionality tests
> res <- testVectorFunctionality(from.numeric=function(i)
as.POSIXct("2001/01/01") + 24*3600*i, verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### POSIXlt fails the basic functionality tests because length() for
POSIXlt always returns 9
> res <- testVectorFunctionality(from.numeric=function(i)
as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=FALSE)
Failed 9 of 17 basic tests, 0 of 0 extra tests, and 0 of 0 bonus tests
> res <- testVectorFunctionality(from.numeric=function(i)
as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=TRUE)
Testing basic vector functionality for class ['POSIXt', 'POSIXlt']
Failed consistency check: length(x1) == 1L
Failed consistency check: length(x0) == 0L
Failed consistency check: length(xa) == xa.len
Failed consistency check: length(xb) == xb.len
Failed consistency check: length(c(x1, xa)) == xa.len + x1.len
Failed consistency check: length(c(x0, xa)) == xa.len
Failed consistency check: length(c(xa, xb)) == xa.len + xb.len
Failed consistency check: xa[-length(xa)] == xa[seq(len = xa.len - 1)]
Failed consistency check: length(xa[0]) == 0L
In 17 basic consistency tests on ['POSIXt', 'POSIXlt'], had the
following outcomes: failure:9, ok:8
'failure' tests (9) involved: '[':2, c:3, length:9
'ok' tests (8) involved: '[':2, c:6
Did not perform any extra consistency tests on ['POSIXt', 'POSIXlt']
Did not perform any bonus consistency tests on ['POSIXt', 'POSIXlt']
>
> ### define length() for POSIXlt and now POSIXlt passes the
functionality tests
> length.POSIXlt <- function(x) length(x$sec)
> res <- testVectorFunctionality(from.numeric=function(i)
as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
source("testVectorFunctionality.R")
library(chron)
if (exists("length.POSIXlt")) remove(list="length.POSIXlt")
### 'character' passes the functionality tests
res <- testVectorFunctionality(CLASS="character", verbose=FALSE)
### 'numeric' passes the functionality tests
res <- testVectorFunctionality(CLASS="numeric", verbose=FALSE)
### 'integer' passes the functionality tests
res <- testVectorFunctionality(CLASS="integer", verbose=FALSE)
### 'Date' passes the functionality tests
res <- testVectorFunctionality(from.numeric=function(i) as.Date("2001/01/01") +
i, verbose=FALSE)
### chron 'times' passes the basic, but not the extra functionality tests
res <- testVectorFunctionality(from.numeric=function(i) chron(times=i),
verbose=FALSE)
res <- testVectorFunctionality(from.numeric=function(i) chron(times=i),
verbose=TRUE)
### chron 'dates' does not pass the basic functionality tests
res <- testVectorFunctionality(from.numeric=function(i) chron(i), verbose=FALSE)
res <- testVectorFunctionality(from.numeric=function(i) chron(i), verbose=TRUE)
# The reason for the failure with c() is that it removes names on the origin in
chron 'dates'
eval(quote(all.equal(c(x1), x1)), res$bindings)
attr(eval(quote(x1), res$bindings), "origin")
attr(eval(quote(c(x1)), res$bindings), "origin")
### POSIXct passes the functionality tests
res <- testVectorFunctionality(from.numeric=function(i)
as.POSIXct("2001/01/01") + 24*3600*i, verbose=FALSE)
### POSIXlt fails the basic functionality tests because length() for POSIXlt
always returns 9
res <- testVectorFunctionality(from.numeric=function(i)
as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=FALSE)
res <- testVectorFunctionality(from.numeric=function(i)
as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=TRUE)
### define length() for POSIXlt and now POSIXlt passes the functionality tests
length.POSIXlt <- function(x) length(x$sec)
res <- testVectorFunctionality(from.numeric=function(i)
as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=FALSE)
> source("testVectorFunctionality.R")
> library(chron)
> if (exists("length.POSIXlt")) remove(list="length.POSIXlt")
>
> ### 'character' passes the functionality tests
> res <- testVectorFunctionality(CLASS="character", verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### 'numeric' passes the functionality tests
> res <- testVectorFunctionality(CLASS="numeric", verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### 'integer' passes the functionality tests
> res <- testVectorFunctionality(CLASS="integer", verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### 'Date' passes the functionality tests
> res <- testVectorFunctionality(from.numeric=function(i) as.Date("2001/01/01")
> + i, verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### chron 'times' passes the basic, but not the extra functionality tests
> res <- testVectorFunctionality(from.numeric=function(i) chron(times=i),
> verbose=FALSE)
Failed 0 of 17 basic tests, 12 of 17 extra tests, and 0 of 0 bonus tests
> res <- testVectorFunctionality(from.numeric=function(i) chron(times=i),
> verbose=TRUE)
Testing basic vector functionality for class 'times'
Testing extra vector functionality for class 'times'
Failed consistency check: unique(xa) == xa
Failed consistency check: unique(xb) == xb
Failed consistency check: unique(x0) == x0
Failed consistency check: unique(x1) == x1
Failed consistency check: unique(xA) == xA[!duplicated(xA)]
Failed consistency check: rep(x1, 3) == c(x1, x1, x1)
Failed consistency check: rep(xa, 3) == c(xa, xa, xa)
Failed consistency check: rep(xb, 2) == c(xb, xb)
Failed consistency check: rep(x1, 0) == x1[0]
Failed consistency check: rep(xa, each = 3) == xa[rep(seq(len = xa.len), each
= 3)]
Failed consistency check: rep(xb, each = 2) == xb[rep(seq(len = xb.len), each
= 2)]
Failed consistency check: rep(xa, length.out = xa.len + 1) == c(xa, xa[1])
In 17 basic consistency tests on 'times', had the following outcomes: ok:17
'ok' tests (17) involved: '[':4, c:9, length:9
In 17 extra consistency tests on 'times', had the following outcomes:
failure:12, ok:5
'failure' tests (12) involved: duplicated:1, rep:7, unique:5
'ok' tests (5) involved: duplicated:5
Did not perform any bonus consistency tests on 'times'
>
> ### chron 'dates' does not pass the basic functionality tests
> res <- testVectorFunctionality(from.numeric=function(i) chron(i),
> verbose=FALSE)
Failed 6 of 17 basic tests, 0 of 0 extra tests, and 0 of 0 bonus tests
> res <- testVectorFunctionality(from.numeric=function(i) chron(i),
> verbose=TRUE)
Testing basic vector functionality for class ['dates', 'times']
Failed consistency check: c(x1) == x1
Failed consistency check: c(x1, x0) == x1
Failed consistency check: c(x0, x1) == x1
Failed consistency check: c(xa) == xa
Failed consistency check: c(xa, x0) == xa
Failed consistency check: c(x0, xa) == xa
In 17 basic consistency tests on ['dates', 'times'], had the following
outcomes: failure:6, ok:11
'failure' tests (6) involved: c:6
'ok' tests (11) involved: '[':4, c:3, length:9
Did not perform any extra consistency tests on ['dates', 'times']
Did not perform any bonus consistency tests on ['dates', 'times']
> # The reason for the failure with c() is that it removes names on the origin
> in chron 'dates'
> eval(quote(all.equal(c(x1), x1)), res$bindings)
[1] "Attributes: < Component 3: names for current but not for target >"
> attr(eval(quote(x1), res$bindings), "origin")
month day year
1 1 1970
> attr(eval(quote(c(x1)), res$bindings), "origin")
[1] 1 1 1970
>
> ### POSIXct passes the functionality tests
> res <- testVectorFunctionality(from.numeric=function(i)
> as.POSIXct("2001/01/01") + 24*3600*i, verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
> ### POSIXlt fails the basic functionality tests because length() for POSIXlt
> always returns 9
> res <- testVectorFunctionality(from.numeric=function(i)
> as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=FALSE)
Failed 9 of 17 basic tests, 0 of 0 extra tests, and 0 of 0 bonus tests
> res <- testVectorFunctionality(from.numeric=function(i)
> as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=TRUE)
Testing basic vector functionality for class ['POSIXt', 'POSIXlt']
Failed consistency check: length(x1) == 1L
Failed consistency check: length(x0) == 0L
Failed consistency check: length(xa) == xa.len
Failed consistency check: length(xb) == xb.len
Failed consistency check: length(c(x1, xa)) == xa.len + x1.len
Failed consistency check: length(c(x0, xa)) == xa.len
Failed consistency check: length(c(xa, xb)) == xa.len + xb.len
Failed consistency check: xa[-length(xa)] == xa[seq(len = xa.len - 1)]
Failed consistency check: length(xa[0]) == 0L
In 17 basic consistency tests on ['POSIXt', 'POSIXlt'], had the following
outcomes: failure:9, ok:8
'failure' tests (9) involved: '[':2, c:3, length:9
'ok' tests (8) involved: '[':2, c:6
Did not perform any extra consistency tests on ['POSIXt', 'POSIXlt']
Did not perform any bonus consistency tests on ['POSIXt', 'POSIXlt']
>
> ### define length() for POSIXlt and now POSIXlt passes the functionality tests
> length.POSIXlt <- function(x) length(x$sec)
> res <- testVectorFunctionality(from.numeric=function(i)
> as.POSIXlt(as.POSIXlt("2001/01/01") + 24*3600*i), verbose=FALSE)
Passed all 17 basic tests, 17 extra tests, and 5 bonus tests
>
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)
}
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
