Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: b2eccd3443
Fetching contributors…

Cannot retrieve contributors at this time

154 lines (138 sloc) 5.426 kb
## check that the 'internal generics' are indeed generic.
x <- structure(pi, class="testit")
xx <- structure("OK", class="testOK")
for(f in ls(.GenericArgsEnv, all.names=TRUE))
{
cat("testing S3 generic '", f, "'\n", sep="")
method <- paste(f, "testit", sep=".")
if(f %in% "seq.int") {
## note that this dispatches on 'seq'.
assign("seq.testit", function(...) xx, .GlobalEnv)
res <- seq.int(x, x)
} else {
if(length(grep("<-$", f)) > 0) {
assign(method, function(x, value) xx, .GlobalEnv)
y <- x
res <- eval(substitute(ff(y, value=pi), list(ff=as.name(f))))
} else {
ff <- get(f, .GenericArgsEnv)
body(ff) <- xx
assign(method, ff, .GlobalEnv)
res <- eval(substitute(ff(x), list(ff=as.name(f))))
}
}
stopifnot(res == xx)
rm(method)
}
## and that no others are generic
for(f in ls(.ArgsEnv, all.names=TRUE))
{
if(f == "browser") next
cat("testing non-generic '", f, "'\n", sep="")
method <- paste(f, "testit", sep=".")
fx <- get(f, envir=.ArgsEnv)
body(fx) <- quote(return(42))
assign(method, fx, .GlobalEnv)
na <- length(formals(fx))
res <- NULL
if(na == 1)
res <- try(eval(substitute(ff(x), list(ff=as.name(f)))), silent = TRUE)
else if(na == 2)
res <- try(eval(substitute(ff(x, x), list(ff=as.name(f)))), silent = TRUE)
if(!inherits(res, "try-error") && identical(res, 42)) stop("is generic")
rm(method)
}
## check that all primitives are accounted for in .[Generic]ArgsEnv.
## and nothing else
ff <- ls("package:base", all.names=TRUE)
ff <- ff[sapply(ff, function(x) is.primitive(get(x, "package:base")))]
lang_elements <-
c('$', '$<-', '&&', '(', ':', '<-', '<<-', '=', '@',
'[', '[<-', '[[', '[[<-', 'break', 'for', 'function', 'if', 'next',
'repeat', 'return', 'while', '{', '||', '~')
known <- c(ls(.GenericArgsEnv, all.names=TRUE),
ls(.ArgsEnv, all.names=TRUE),
lang_elements)
stopifnot(ff %in% known, known %in% ff)
## check which are not considered as possibles for S4 generic
ff4 <- names(methods:::.BasicFunsList)
# as.double and as.real are the same as as.numeric
S4generic <- ff %in% c(ff4, "as.double", "as.real")
notS4 <- ff[!S4generic]
if(length(notS4))
cat("primitives not covered in methods:::.BasicFunsList:",
paste(sQuote(notS4), collapse=", "), "\n")
stopifnot(S4generic)
# functions which are listed but not primitive
extraS4 <- c('all', 'any', 'max', 'min', 'prod', 'range',
'round', 'signif', 'sum')
ff4[!ff4 %in% c(ff, extraS4)]
stopifnot(ff4 %in% c(ff, extraS4))
## primitives which are not internally generic cannot have S4 methods
## unless specifically arranged (e.g. %*%)
nongen_prims <- ff[!ff %in% ls(.GenericArgsEnv, all.names=TRUE)]
ff3 <- names(methods:::.BasicFunsList)[sapply(methods:::.BasicFunsList, function(x) is.logical(x) && !x)]
ex <- nongen_prims[!nongen_prims %in% c("$", "$<-", "[", "[[" ,"[[<-", "[<-", "%*%", ff3)]
if(length(ex))
cat("non-generic primitives not excluded in methods:::.BasicFunsList:",
paste(sQuote(ex), collapse=", "), "\n")
stopifnot(length(ex) == 0)
## Now check that (most of) those which are listed really are generic.
require(methods)
setClass("foo", representation(x="numeric", y="numeric"))
xx <- new("foo", x=1, y=2)
S4gen <- names(methods:::.BasicFunsList)[sapply(methods:::.BasicFunsList, function(x) is.function(x))]
for(f in S4gen) {
g <- get(f)
if(is.primitive(g)) g <- getGeneric(f) # should error on non-Generics.
ff <- args(g)
body(ff) <- "testit"
nm <- names(formals(ff))
## the Summary group gives problems
if(nm[1] == '...') {
cat("skipping '", f, "'\n", sep="")
next
}
cat("testing '", f, "'\n", sep="")
setMethod(f, "foo", ff)
## might have created a generic, so redo 'get'
stopifnot(identical(getGeneric(f)(xx), "testit"))
}
## check that they do argument matching, or at least check names
except <- c("call", "switch", ".C", ".Fortran", ".Call", ".External",
".External2", ".Call.graphics", ".External.graphics",
".subset", ".subset2", ".primTrace", ".primUntrace",
"lazyLoadDBfetch", ".Internal", ".Primitive", "^", "|",
"%*%", "rep", "seq.int",
## these may not be enabled
"tracemem", "retracemem", "untracemem")
for(f in ls(.GenericArgsEnv, all.names=TRUE)[-(1:15)])
{
if (f %in% except) next
g <- get(f, envir = .GenericArgsEnv)
an <- names(formals(args(g)))
if(length(an) >0 && an[1] == "...") next
an <- an[an != "..."]
a <- rep(list(NULL), length(an))
names(a) <- c("zZ", an[-1])
res <- try(do.call(f, a), silent = TRUE)
m <- geterrmessage()
if(!grepl('does not match|unused argument', m))
stop("failure on ", f)
}
for(f in ls(.ArgsEnv, all.names=TRUE))
{
if (f %in% except) next
g <- get(f, envir = .ArgsEnv)
an <- names(formals(args(g)))
if(length(an) >0 && an[1] == "...") next
an <- an[an != "..."]
if(length(an)) {
a <- rep(list(NULL), length(an))
names(a) <- c("zZ", an[-1])
} else a <- list(zZ=NULL)
res <- try(do.call(f, a), silent = TRUE)
m <- geterrmessage()
if(!grepl('does not match|unused argument|requires 0|native symbol', m))
stop("failure on ", f)
}
Jump to Line
Something went wrong with that request. Please try again.