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
|
###########################################################################/**
# @RdocDefault findDispatchMethodsS3
#
# @title "Finds the S3 methods that a generic function would call"
#
# \description{
# @get "title", ordered according to an S3 @see "base::class" @vector.
# }
#
# @synopsis
#
# \arguments{
# \item{methodName}{A @character string specifying the name of a
# generic function.}
# \item{classNames}{A @character @vector of @see "base::class" names.}
# \item{firstOnly}{If @TRUE, only the first method is returned.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a names @list structure.
# }
#
# \seealso{
# @see "getDispatchMethodS3".
# }
#
# @author
#
# @keyword programming
# @keyword methods
# @keyword internal
#*/###########################################################################
setMethodS3("findDispatchMethodsS3", "default", function(methodName, classNames, firstOnly=FALSE, ...) {
# Argument 'methodName':
methodName <- as.character(methodName)
if (length(methodName) == 0) {
stop("Argument 'methodName' is empty.")
}
if (length(methodName) > 1) {
stop("Argument 'methodName' must only contain one element: ", paste(head(methodName), collapse=", "))
}
# Argument 'classNames':
classNames <- as.character(classNames)
if (length(classNames) == 0) {
stop("Argument 'classNames' is empty.")
}
# Argument 'firstOnly':
firstOnly <- as.logical(firstOnly)
res <- list()
for (kk in seq_along(classNames)) {
className <- classNames[kk]
fcnName <- paste(methodName, className, sep=".")
obj <- do.call(getAnywhere, list(fcnName))
if (length(obj$objs) == 0) {
# No matching objects
next
}
# WORKAROUND: In R (< 3.1.?) there is a bug in getAnywhere()
# causing it to return garbage in parts of the 'objs' list.
hasBug <- (length(obj$objs) > length(obj$where))
if (hasBug) {
## Rebuild 'objs' manually
n <- length(obj$where)
obj$objs <- vector("list", length=n)
for (ii in seq_len(n)) {
where <- obj$where[[ii]]
tryCatch({
if (grepl("^namespace:", where)) {
env <- asNamespace(gsub("^namespace:", "", where))
} else {
env <- as.environment(where)
}
if (exists(fcnName, envir=env)) {
obj$objs[[ii]] <- get(fcnName, envir=env)
}
}, error = function(ex) {})
} # for (ii ...)
}
# Keep only functions
keep <- which(sapply(obj$objs, FUN=is.function))
if (length(keep) == 0) {
# No functions
next
}
# Keep the first function
first <- keep[1]
fcn <- obj$objs[[first]]
where <- obj$where[first]
resKK <- list()
resKK$class <- className
resKK$name <- methodName
resKK$fullname <- fcnName
resKK$fcn <- fcn
resKK$where <- obj$where
res[[className]] <- resKK
# Return only the first match?
if (firstOnly) {
break
}
} # for (kk ...)
res
}, private=TRUE) # findDispatchMethodsS3()
|
