1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
## check that the 'internal generics' are indeed generic.
x <- structure(pi, class="testit")
xx <- structure("OK", class="testOK")
internalGenerics <- ls(.GenericArgsEnv, all.names=TRUE)
for(f in internalGenerics)
{
cat("testing S3 generic '", f, "'\n", sep="")
method <- paste(f, "testit", sep=".")
if(f == "seq.int") {
## note that this dispatches on 'seq'.
assign("seq.testit", function(...) xx, .GlobalEnv)
res <- seq.int(x, x)
} else {
if(grepl("<-$", f)) {
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 <- if(f %in% "%*%") # 2 args
eval(substitute(ff(x,x), list(ff=as.name(f))))
else 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,
## apart from the language elements:
ff <- as.list(baseenv(), all.names=TRUE)
ff <- names(ff)[vapply(ff, is.primitive, logical(1L))]
known <- c(names(.GenericArgsEnv), names(.ArgsEnv), tools::langElts)
stopifnot(ff %in% known, known %in% ff) ## identical(ff, known) "modulo sort()"
## check which are not considered as possibles for S4 generic (*all* should)
ff4 <- names(meth.FList <- methods:::.BasicFunsList)
# as.double is the same as as.numeric
S4generic <- ff %in% c(ff4, "as.double")
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('unlist', 'as.vector', 'lengths') # == setdiff(ff4, ff)
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% internalGenerics]
ff3 <- ff4[vapply(meth.FList, function(x) is.logical(x) && !x, NA, USE.NAMES=FALSE)]
ex <- nongen_prims[!nongen_prims %in%
c("$", "$<-", "[", "[[" ,"[[<-", "[<-"
, "%*%", "crossprod", "tcrossprod"
, 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 <- ff4[vapply(meth.FList, is.function, NA, USE.NAMES=FALSE)]
for(f in S4gen) {
g <- get(f)
if(!is(g, "genericFunction")) g <- getGeneric(f) # 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",
unlist(lapply(c("Arith", "Compare", "Logic"), getGroupMembers)),
"%*%", "crossprod", "tcrossprod", # "matrixOps"
"!", "::", ":::",
"rep", "seq.int", "forceAndCall",
"Tailcall",
## these may not be enabled
"tracemem", "retracemem", "untracemem")
for(f in internalGenerics)
{
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))
## message("failure on ", f,":\n\t\t", m)
stop("failure on ", f,":\n\t", m)
}
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|valid .* object', m))
stop("failure on ", f)
}
|
