| Line 1... |
Line 1... |
| 1 |
## check that the 'internal generics' are indeed generic.
|
1 |
## check that the 'internal generics' are indeed generic.
|
| 2 |
|
2 |
|
| 3 |
x <- structure(pi, class="testit")
|
3 |
x <- structure(pi, class="testit")
|
| 4 |
xx <- structure("OK", class="testOK")
|
4 |
xx <- structure("OK", class="testOK")
|
| 5 |
|
5 |
|
| 6 |
for(f in ls(.GenericArgsEnv, all.names=TRUE))
|
6 |
internalGenerics <- ls(.GenericArgsEnv, all.names=TRUE)
|
| - |
|
7 |
for(f in internalGenerics)
|
| 7 |
{
|
8 |
{
|
| 8 |
cat("testing S3 generic '", f, "'\n", sep="")
|
9 |
cat("testing S3 generic '", f, "'\n", sep="")
|
| 9 |
method <- paste(f, "testit", sep=".")
|
10 |
method <- paste(f, "testit", sep=".")
|
| 10 |
if(f %in% "seq.int") {
|
11 |
if(f == "seq.int") {
|
| 11 |
## note that this dispatches on 'seq'.
|
12 |
## note that this dispatches on 'seq'.
|
| 12 |
assign("seq.testit", function(...) xx, .GlobalEnv)
|
13 |
assign("seq.testit", function(...) xx, .GlobalEnv)
|
| 13 |
res <- seq.int(x, x)
|
14 |
res <- seq.int(x, x)
|
| 14 |
} else {
|
15 |
} else {
|
| 15 |
if(length(grep("<-$", f)) > 0) {
|
16 |
if(grepl("<-$", f)) {
|
| 16 |
assign(method, function(x, value) xx, .GlobalEnv)
|
17 |
assign(method, function(x, value) xx, .GlobalEnv)
|
| 17 |
y <- x
|
18 |
y <- x
|
| 18 |
res <- eval(substitute(ff(y, value=pi), list(ff=as.name(f))))
|
19 |
res <- eval(substitute(ff(y, value=pi), list(ff=as.name(f))))
|
| 19 |
} else {
|
20 |
} else {
|
| 20 |
ff <- get(f, .GenericArgsEnv)
|
21 |
ff <- get(f, .GenericArgsEnv)
|
| 21 |
body(ff) <- xx
|
22 |
body(ff) <- xx
|
| 22 |
assign(method, ff, .GlobalEnv)
|
23 |
assign(method, ff, .GlobalEnv)
|
| - |
|
24 |
res <- if(f %in% "%*%") # 2 args
|
| - |
|
25 |
eval(substitute(ff(x,x), list(ff=as.name(f))))
|
| 23 |
res <- eval(substitute(ff(x), list(ff=as.name(f))))
|
26 |
else eval(substitute(ff(x), list(ff=as.name(f))))
|
| 24 |
}
|
27 |
}
|
| 25 |
}
|
28 |
}
|
| 26 |
stopifnot(res == xx)
|
29 |
stopifnot(res == xx)
|
| 27 |
rm(method)
|
30 |
rm(method)
|
| 28 |
}
|
31 |
}
|
| Line 51... |
Line 54... |
| 51 |
## apart from the language elements:
|
54 |
## apart from the language elements:
|
| 52 |
ff <- as.list(baseenv(), all.names=TRUE)
|
55 |
ff <- as.list(baseenv(), all.names=TRUE)
|
| 53 |
ff <- names(ff)[vapply(ff, is.primitive, logical(1L))]
|
56 |
ff <- names(ff)[vapply(ff, is.primitive, logical(1L))]
|
| 54 |
|
57 |
|
| 55 |
known <- c(names(.GenericArgsEnv), names(.ArgsEnv), tools::langElts)
|
58 |
known <- c(names(.GenericArgsEnv), names(.ArgsEnv), tools::langElts)
|
| 56 |
stopifnot(ff %in% known, known %in% ff)
|
59 |
stopifnot(ff %in% known, known %in% ff) ## identical(ff, known) "modulo sort()"
|
| 57 |
|
60 |
|
| 58 |
|
61 |
|
| 59 |
## check which are not considered as possibles for S4 generic
|
62 |
## check which are not considered as possibles for S4 generic (*all* should)
|
| 60 |
ff4 <- names(meth.FList <- methods:::.BasicFunsList)
|
63 |
ff4 <- names(meth.FList <- methods:::.BasicFunsList)
|
| 61 |
# as.double is the same as as.numeric
|
64 |
# as.double is the same as as.numeric
|
| 62 |
S4generic <- ff %in% c(ff4, "as.double")
|
65 |
S4generic <- ff %in% c(ff4, "as.double")
|
| 63 |
notS4 <- ff[!S4generic]
|
66 |
notS4 <- ff[!S4generic]
|
| 64 |
if(length(notS4))
|
67 |
if(length(notS4))
|
| 65 |
cat("primitives not covered in methods:::.BasicFunsList:",
|
68 |
cat("primitives not covered in methods:::.BasicFunsList:",
|
| 66 |
paste(sQuote(notS4), collapse=", "), "\n")
|
69 |
paste(sQuote(notS4), collapse=", "), "\n")
|
| 67 |
stopifnot(S4generic)
|
70 |
stopifnot(S4generic)
|
| 68 |
|
71 |
|
| 69 |
# functions which are listed but not primitive
|
72 |
# functions which are listed but not primitive
|
| 70 |
extraS4 <- c('unlist', 'as.vector', 'lengths')
|
73 |
extraS4 <- c('unlist', 'as.vector', 'lengths') # == setdiff(ff4, ff)
|
| 71 |
ff4[!ff4 %in% c(ff, extraS4)]
|
74 |
ff4[!ff4 %in% c(ff, extraS4)]
|
| 72 |
stopifnot(ff4 %in% c(ff, extraS4))
|
75 |
stopifnot(ff4 %in% c(ff, extraS4))
|
| 73 |
|
76 |
|
| 74 |
|
77 |
|
| 75 |
## primitives which are not internally generic cannot have S4 methods
|
78 |
## primitives which are not internally generic cannot have S4 methods
|
| 76 |
## unless specifically arranged (e.g. %*%)
|
79 |
## unless specifically arranged (e.g. %*%)
|
| 77 |
nongen_prims <- ff[!ff %in% ls(.GenericArgsEnv, all.names=TRUE)]
|
80 |
nongen_prims <- ff[!ff %in% internalGenerics]
|
| 78 |
ff3 <- ff4[vapply(meth.FList, function(x) is.logical(x) && !x, NA, USE.NAMES=FALSE)]
|
81 |
ff3 <- ff4[vapply(meth.FList, function(x) is.logical(x) && !x, NA, USE.NAMES=FALSE)]
|
| - |
|
82 |
ex <- nongen_prims[!nongen_prims %in%
|
| 79 |
ex <- nongen_prims[!nongen_prims %in% c("$", "$<-", "[", "[[" ,"[[<-", "[<-", "%*%", ff3)]
|
83 |
c("$", "$<-", "[", "[[" ,"[[<-", "[<-"
|
| - |
|
84 |
, "%*%", "crossprod", "tcrossprod"
|
| - |
|
85 |
, ff3)]
|
| 80 |
if(length(ex))
|
86 |
if(length(ex))
|
| 81 |
cat("non-generic primitives not excluded in methods:::.BasicFunsList:",
|
87 |
cat("non-generic primitives not excluded in methods:::.BasicFunsList:",
|
| 82 |
paste(sQuote(ex), collapse=", "), "\n")
|
88 |
paste(sQuote(ex), collapse=", "), "\n")
|
| 83 |
stopifnot(length(ex) == 0)
|
89 |
stopifnot(length(ex) == 0)
|
| 84 |
|
90 |
|
| Line 106... |
Line 112... |
| 106 |
|
112 |
|
| 107 |
## check that they do argument matching, or at least check names
|
113 |
## check that they do argument matching, or at least check names
|
| 108 |
except <- c("call", "switch", ".C", ".Fortran", ".Call", ".External",
|
114 |
except <- c("call", "switch", ".C", ".Fortran", ".Call", ".External",
|
| 109 |
".External2", ".Call.graphics", ".External.graphics",
|
115 |
".External2", ".Call.graphics", ".External.graphics",
|
| 110 |
".subset", ".subset2", ".primTrace", ".primUntrace",
|
116 |
".subset", ".subset2", ".primTrace", ".primUntrace",
|
| 111 |
"lazyLoadDBfetch", ".Internal", ".Primitive", "^", "|",
|
117 |
"lazyLoadDBfetch", ".Internal", ".Primitive",
|
| - |
|
118 |
unlist(lapply(c("Arith", "Compare", "Logic"), getGroupMembers)),
|
| - |
|
119 |
"%*%", "crossprod", "tcrossprod", # "matrixOps"
|
| - |
|
120 |
"!", "::", ":::",
|
| 112 |
"::", ":::", "%*%", "rep", "seq.int", "forceAndCall",
|
121 |
"rep", "seq.int", "forceAndCall",
|
| 113 |
"Tailcall",
|
122 |
"Tailcall",
|
| 114 |
## these may not be enabled
|
123 |
## these may not be enabled
|
| 115 |
"tracemem", "retracemem", "untracemem")
|
124 |
"tracemem", "retracemem", "untracemem")
|
| 116 |
|
125 |
|
| 117 |
for(f in ls(.GenericArgsEnv, all.names=TRUE)[-(1:15)])
|
126 |
for(f in internalGenerics)
|
| 118 |
{
|
127 |
{
|
| 119 |
if (f %in% except) next
|
128 |
if (f %in% except) next
|
| 120 |
g <- get(f, envir = .GenericArgsEnv)
|
129 |
g <- get(f, envir = .GenericArgsEnv)
|
| 121 |
an <- names(formals(args(g)))
|
130 |
an <- names(formals(args(g)))
|
| 122 |
if(length(an) > 0 && an[1] == "...") next
|
131 |
if(length(an) > 0 && an[1] == "...") next
|
| Line 124... |
Line 133... |
| 124 |
a <- rep(list(NULL), length(an))
|
133 |
a <- rep(list(NULL), length(an))
|
| 125 |
names(a) <- c("zZ", an[-1])
|
134 |
names(a) <- c("zZ", an[-1])
|
| 126 |
res <- try(do.call(f, a), silent = TRUE)
|
135 |
res <- try(do.call(f, a), silent = TRUE)
|
| 127 |
m <- geterrmessage()
|
136 |
m <- geterrmessage()
|
| 128 |
if(!grepl('does not match|unused argument', m))
|
137 |
if(!grepl('does not match|unused argument', m))
|
| - |
|
138 |
## message("failure on ", f,":\n\t\t", m)
|
| 129 |
stop("failure on ", f)
|
139 |
stop("failure on ", f,":\n\t", m)
|
| 130 |
}
|
140 |
}
|
| 131 |
|
141 |
|
| - |
|
142 |
|
| 132 |
for(f in ls(.ArgsEnv, all.names=TRUE))
|
143 |
for(f in ls(.ArgsEnv, all.names=TRUE))
|
| 133 |
{
|
144 |
{
|
| 134 |
if (f %in% except) next
|
145 |
if (f %in% except) next
|
| 135 |
g <- get(f, envir = .ArgsEnv)
|
146 |
g <- get(f, envir = .ArgsEnv)
|
| 136 |
an <- names(formals(args(g)))
|
147 |
an <- names(formals(args(g)))
|
The R Project SVN
R