Permalink
Browse files

allow methods with duplicate class names in separate packages

git-svn-id: https://svn.r-project.org/R/trunk@56466 00db46b3-68df-0310-9c12-caf00c1e9a41
  • Loading branch information...
jmc
jmc committed Jul 21, 2011
1 parent c4f80bc commit 5b7e035319ce242f8bcf179a2a346af083e21e89
View
@@ -552,10 +552,10 @@
search path.
\item In principle, S4 classes from different packages could
have the same name. This has never worked, but a first step has
been taken: Classes should now be found correctly from each
package's namespace or given the package slot. Methods for the
same generic function may still be selected incorrectly.
have the same name. This has not previously worked. Changes
have now been installed that should allow such classes and
permit methods to use them. There are many possible cases and it's
unlikely they all have been covered yet.
\item Work around an issue in Linux (a system \code{select} call
resetting \code{tv}) which prevented internet operations from
@@ -592,14 +592,14 @@ setMethod <-
signature, margs, definition)
else
whereMethods <- NULL
allMethods <- getMethodsForDispatch(fdef)
mtable <- getMethodsForDispatch(fdef)
if(cacheOnAssign(where)) { # will be FALSE for sourceEnvironment's
## cache in both direct and inherited tables
.cacheMethodInTable(fdef, signature, definition, allMethods) #direct
.cacheMethodInTable(fdef, signature, definition, mtable) #direct
.cacheMethodInTable(fdef, signature, definition) # inherited, by default
if(is.not.base)
.addToMetaTable(fdef, signature, definition, where, nSig)
resetGeneric(f, fdef, allMethods, gwhere, deflt) # Note: gwhere not used by resetGeneric
resetGeneric(f, fdef, mtable, gwhere, deflt) # Note: gwhere not used by resetGeneric
}
## assigns the methodslist object
## and deals with flags for primitives & for updating group members
@@ -448,14 +448,47 @@ matchSignature <-
if(!is(fun, "genericFunction"))
stop(gettextf("trying to match a method signature to an object (of class \"%s\") that is not a generic function", class(fun)), domain = NA)
anames <- fun@signature
if(!is(signature, "list") && !is(signature, "character"))
stop(gettextf("trying to match a method signature of class \"%s\"; expects a list or a character vector", class(signature)), domain = NA)
if(length(signature) == 0)
return(character())
sigClasses <- as.character(signature)
if(is(signature,"character")) {
pkgs <- packageSlot(signature) # includes case of "ObjectsWithPackage"
if(is.null(pkgs))
pkgs <- character(length(signature))
else if(length(pkgs) != length(signature))
stop("invalid \"package\" slot or attribute, wrong length")
sigClasses <- as.character(signature)
}
else if(is(signature, "list")) {
sigClasses <- pkgs <- character(length(signature))
for(i in seq_along(signature)) {
cli <- signature[[i]]
if(is(cli, "classRepresentation")) {
sigClasses[[i]] <- cli@className
pkgs[[i]] <- cli@package
}
else if(is(cli, "character") && length(cli) == 1) {
sigClasses[[i]] <- cli
pkgi <- packageSlot(cli)
if(is.character(pkgi))
pkgs[[i]] <- pkgi
}
else
stop(gettextf("invalid element in a list for \"signature\" argument; element %d is neither a class definition nor a class name",
i), domain = NA)
}
}
else
stop(gettextf("trying to match a method signature of class \"%s\"; expects a list or a character vector", class(signature)), domain = NA)
if(!identical(where, baseenv())) {
unknown <- !sapply(sigClasses, function(x, where)
isClass(x, where=where), where = where)
## fill in package information, warn about undefined classes
unknown <- !nzchar(pkgs)
for(i in seq_along(sigClasses)[unknown]) {
cli <- getClassDef(sigClasses[[i]], where)
if(!is.null(cli)) {
pkgs[[i]] <- cli@package
unknown[[i]] <- FALSE
}
}
if(any(unknown)) {
unknown <- unique(sigClasses[unknown])
## coerce(), i.e., setAs() may use *one* unknown class
@@ -509,13 +542,19 @@ matchSignature <-
}
n <- length(anames)
value <- rep("ANY", n)
valueP <- rep("methods", n)
names(value) <- anames
value[which] <- sigClasses
valueP[which] <- pkgs
unspec <- value == "ANY"
## remove the trailing unspecified classes
while(n > 1 && unspec[[n]])
n <- n-1
length(value) <- n
length(value) <- length(valueP) <- n
attr(value, "package") <- valueP
## <FIXME> Is there a reason (bootstrapping?) why this
## is not an actual object from class "signature"?
## See .MakeSignature() </FIXME>
value
}
@@ -650,7 +689,7 @@ promptMethods <- function(f, filename = NULL, methods)
## Title and description are ok as auto-generated: should
## they be flagged as such (via '~~' which are quite often
## left in by authors)?
title =
title =
sprintf("\\title{ ~~ Methods for Function \\code{%s} %s ~~}",
f, packageString),
description =
@@ -816,7 +855,7 @@ asMethodDefinition <- function(def, signature = list(), sealed = FALSE, fdef = d
else
assign(this, TRUE, envir = .MlistDepTable)
}
if(missing(this))
if(missing(this))
msg <-"Use of the \"MethodsList\" meta data objects is deprecated."
else if(is.character(this))
msg <- gettextf("%s, along with other use of the \"MethodsList\" metadata objects, is deprecated.", dQuote(this))
@@ -38,7 +38,7 @@
setIs("MethodsList", "optionalMethod", where = envir) #only until MethodsList class is defunct
## signatures -- used mainly as named character vectors
setClass("signature", representation("character", names = "character"), where = envir); clList <- c(clList, "signature")
setClass("signature", representation("character", names = "character", package = "character"), where = envir); clList <- c(clList, "signature")
## formal method definition for all but primitives
setClass("MethodDefinition", contains = "function",
@@ -359,10 +359,17 @@
.MakeSignature <- function(object, def = NULL, signature, fdef = def) {
## fill in the signature information in object
## In effect, object must come from class "signature" or a subclass
## but the only explicit requirement is that it has compatible
## .Data and "package" slots
signature <- unlist(signature)
if(length(signature)>0) {
classes <- as.character(signature)
sigArgs <- names(signature)
pkgs <- attr(signature, "package")
if(is.null(pkgs))
pkgs <- character(length(signature))
if(is(fdef, "genericFunction"))
formalNames <- fdef@signature
else if(is.function(def)) {
@@ -383,10 +390,8 @@
paste(formalNames, collapse = ", ")),
domain = NA)
}
## the named classes become the signature object
class(signature) <- class(object)
signature
object@.Data <- signature
object@package <- pkgs
}
else
object
object
}
@@ -1852,6 +1852,13 @@ substituteFunctionArgs <-
## packages a list of classes will be cached
## See .cacheGeneric, etc. for analogous computations for generics
.classTable <- new.env(TRUE, baseenv())
assign("#HAS_DUPLICATE_CLASS_NAMES", FALSE, envir = .classTable)
.duplicateClassesExist <- function(on) {
value <- get("#HAS_DUPLICATE_CLASS_NAMES", envir = .classTable)
if(nargs())
assign("#HAS_DUPLICATE_CLASS_NAMES", on, envir = .classTable)
value
}
.cacheClass <- function(name, def, doSubclasses = FALSE, env) {
if(!identical(doSubclasses, FALSE))
@@ -1880,6 +1887,7 @@ substituteFunctionArgs <-
else
prev[[i]] <- def
def <- prev
.duplicateClassesExist(TRUE)
}
assign(name, def, envir = .classTable)
}
@@ -820,6 +820,21 @@ cacheMetaData <-
{
## a collection of actions performed on attach or detach
## to update class and method information.
pkg <- getPackageName(where)
classes <- getClasses(where)
for(cl in classes) {
cldef <- (if(attach) get(classMetaName(cl), where) # NOT getClassDef, it will use cache
else getClassDef(cl, searchWhere))
if(is(cldef, "classRepresentation")) {
if(attach) {
.cacheClass(cl, cldef, is(cldef, "ClassUnionRepresentation"), where)
}
else if(identical(cldef@package, pkg)) {
.uncacheClass(cl, cldef)
.removeSuperclassBackRefs(cl, cldef, searchWhere)
}
}
}
generics <- .getGenerics(where)
packages <- attr(generics, "package")
if(length(packages) < length(generics))
@@ -832,7 +847,6 @@ cacheMetaData <-
## check for duplicates
dups <- duplicated(generics) & duplicated(packages)
generics <- generics[!dups]
pkg <- getPackageName(where)
for(i in seq_along(generics)) {
f <- generics[[i]]
fpkg <- packages[[i]]
@@ -871,20 +885,6 @@ cacheMetaData <-
methods <- .updateMethodsInTable(fdef, where, attach)
cacheGenericsMetaData(f, fdef, attach, where, fdef@package, methods)
}
classes <- getClasses(where)
for(cl in classes) {
cldef <- (if(attach) get(classMetaName(cl), where) # NOT getClassDef, it will use cache
else getClassDef(cl, searchWhere))
if(is(cldef, "classRepresentation")) {
if(attach) {
.cacheClass(cl, cldef, is(cldef, "ClassUnionRepresentation"), where)
}
else if(identical(cldef@package, pkg)) {
.uncacheClass(cl, cldef)
.removeSuperclassBackRefs(cl, cldef, searchWhere)
}
}
}
invisible(NULL) ## as some people call this at the end of functions
}
@@ -36,7 +36,7 @@ as <-
asMethod <- .quickCoerceSelect(thisClass, Class, coerceFun, coerceMethods)
if(is.null(asMethod)) {
sig <- c(from=thisClass, to = Class)
packageSlot(sig) <- where
## packageSlot(sig) <- where
## try first for an explicit (not inherited) method
## ?? Can this ever succeed if .quickCoerceSelect failed?
asMethod <- selectMethod("coerce", sig, optional = TRUE,
Oops, something went wrong.

0 comments on commit 5b7e035

Please sign in to comment.