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
|
## 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")))]
## NB: there is a another version of this list in tools::undoc()
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 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('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)
}
|
