options(error=traceback, warn = 1) ### merge version called from namespace imports code. Hope to avoid using generic .mergeMethodsTable2 <- function(table, newtable, envir, metaname) { old <- objects(table, all=TRUE) mm <- 1 for( what in old) { mm = get(what, envir =table) if(is(mm, "MethodDefinition")) { mm = length(mm@defined) break } } new = objects(newtable, all=TRUE) ## check that signature length doesn't change canStore <- TRUE for(what in new) { obj <- get(what, envir = newtable) if(is(obj, "MethodDefinition") && length(obj@defined) != mm) { canStore <- FALSE break } } if(canStore) { for(what in new) assign(what, get(what, envir = newtable), envir = table) table } else { # rats! have to get the generic function f <- gsub(".__T__(.*):([^:]+)", "\\1", metaname) package <- gsub(".__T__(.*):([^:]+(.*))", "\\2", metaname) generic <- getGeneric(f, TRUE, envir, package) .mergeMethodsTable(generic, table, newtable, TRUE) table } } ## action on attach, detach to merge methods tables .mergeMethodsTable <- function(generic, table, newtable, add = TRUE) { fenv <- environment(generic) signature <- generic@signature if(!exists(".SigLength", envir = fenv, inherits = FALSE)) .setupMethodsTables(generic) n <- get(".SigLength", envir = fenv) anySig <- rep("ANY", n) anyLabel <- .sigLabel(anySig) newMethods <- objects(newtable, all=TRUE) for(what in newMethods) { obj <- get(what, envir = newtable) if(is.primitive(obj)) sig <- anySig ## Assert doesn't need to be a signature obj., won't change ns else if(is(obj, "MethodDefinition")) sig <- obj@defined else stop(gettextf( "Invalid object in meta table of methods for \"%s\", label \"%s\", had class \"%s\"", generic@generic, what, class(obj))) ns <- length(sig) if(ns == n) {} else { if(ns < n) { sig <- new("signature", generic, c(sig@.Data, rep("ANY", n-ns))) obj@defined <- sig obj@target <- sig what <- .sigLabel(sig) ns <- n } else if(add) { # and ns > n signames <- generic@signature length(signames) <- ns .resetTable(table, ns, signames) assign(".SigLength", ns, envir = fenv) n <- ns } } if(add) assign(what, obj, envir = table) else if(exists(what, envir = table, inherits = FALSE) && !all(obj@defined == "ANY") ) # remove methods, but not the default remove(list = what, envir = table) ## else warning? } } .mlistAddToTable <- function(generic, mlist, table = new.env(TRUE, fenv), add = TRUE) { fenv <- environment(generic) signature <- generic@signature if(!exists(".SigLength", envir = fenv, inherits = FALSE)) .setupMethodsTables(generic) n <- get(".SigLength", envir = fenv, inherits = FALSE) .storeMlist(table, rep("ANY", n), mlist, 1, add, fenv) ## check for more args in the mlist than in the table nNow <- get(".SigLength", envir = fenv, inherits = FALSE) if(nNow > n) { length(signature) <- nNow .resetTable(table, nNow, signature) } table } .storeMlist <- function(table, sig, mlist, i, add, fenv) { ## the methods slot is a list named by class, with elements either ## method definitions or mlists m <- mlist@methods classes <- names(m) for(j in seq(along = m)) { el <- m[[j]] sig[[i]] <- classes[[j]] if(is(el, "MethodDefinition") || is.primitive(el)) { if(add) assign(.sigLabel(sig), el, envir = table) else remove(list = .sigLabel(sig), envir = table) } else if(is(el,"MethodsList")) { i1 <- i+1 if(i1 >= length(sig)) { ## a reset of the labels will be needed assign(".SigLength", i1, envir = fenv) sig <- c(sig, rep("ANY", i1-length(sig))) } Recall(table, sig, el, i1, add, fenv) } else stop("Invalid mlist element for signature \"", classes[[j]], "\" at level ", i, "( should be methods list or method, had class \"", class(el), "\")") } table } .cacheMethodInTable <- function(fdef, sig, def, table = get(".AllMTable", envir = fenv)) { ## store method in cache table. ## called from setMethod() ## also Called from cacheMethod (from as(), ## as<-()) fenv <- environment(fdef) if(!exists(".AllMTable", envir = fenv, inherits = TRUE)) .setupMethodsTables(fdef) sig <- .matchSigLength(sig, fdef, fenv, TRUE) label <- .sigLabel(sig) if(is.null(def)) { if(exists(label, envir = table, inherits = FALSE)) # remove the method (convention for setMethod) remove(list = label, envir = table) } else assign(label, def, envir = table) } .resetTable <- function(table, n, signames) { ## after updating a methods table, the maximum no. of arguments in ## the signature increased to n. Reassign any objects whose label ## does not match n classes from the defined slot anyLabel <- rep("ANY", n); seqN <- 1:n labels <- objects(table, all.names = TRUE) for(what in labels) { method <- get(what, envir = table) if(is.primitive(method)) # stored as default ? label <- anyLabel else if(is(method, "MethodDefinition")) label <- method@defined else stop("Invalid object in methods table (\"", what, "\"), expected a method, got an object of class \"", class(method), "\"") if(length(label) < n) { label@.Data <- ifelse(seqN>length(label), anyLabel, label@.Data) label@names <- signames method@defined <- method@target <- label } newLabel <- .sigLabel(label) if(!identical(what, newLabel)) { assign(newLabel, method, envir = table) remove(list=what, envir = table) } } } ### the tag associated with a method signature. ### Should eventually use the same C code as dispatch, for consistency .sigLabel <- function(sig) ## TODO: should include package; i.e., class:package#class:... ## BUT: not until defined, target slots have classes with package attribute paste(sig, collapse = "#") .findInheritedMethods <- function(classes, fdef, mtable = NULL, table = get(".MTable", envir = environment(fdef)), excluded = NULL, useInherited, returnAll = !(doMtable || doExcluded) ) { ## classes is a list of the class(x) for each arg in generic ## signature, with "missing" for missing args if(!is.environment(table)) { if(is(fdef, "standardGeneric")) stop("Invalid or unset methods table in generic function \"", fdef@generic,"\"") else stop("Trying to find a methods table in a non-generic function") } hasGroup <- length(fdef@group)>0 if(hasGroup) groupGenerics <-.getAllGroups(list(fdef)) doMtable <- is.environment(mtable) doExcluded <- length(excluded)>0 nargs <- length(classes) methods <- list() if(!missing(useInherited) && length(useInherited) < nargs) useInherited <- rep(useInherited, length = nargs) if(hasGroup && !doExcluded) { ## first try for an exact match in a group generic ## If this matches & is cached, it then will be treated as a non-inherited method ## so no further calls here should occur. ## ## doExcluded is the findNextMethod case; we don't regard group methods as ## inherited in the nextMethod sense, since they have the same signature label <- .sigLabel(classes) direct <- .getGroupMethods(label, groupGenerics, FALSE) if(doExcluded && length(direct) > 0) direct <- direct[is.na(match(names(direct), excluded))] if(length(direct) > 0 && doMtable) { assign(label, direct[[1]], envir = mtable) return(direct) ## else must be returnAll, so include the group direct method methods<- direct } ## else, continue because we may want all defined methods } def <- getClass(classes[[1]], .Force = TRUE) if(missing(useInherited) || useInherited[[1]]) labels <- c(classes[[1]], names(def@contains), "ANY") else labels <- classes[[1]] if(nargs > 1) { classDefs <- vector("list", nargs) classDefs[[1]] <- def for(i in 2:nargs) { cc <- classDefs[[i]] <- getClass(classes[[i]], .Force = TRUE) if(missing(useInherited) || useInherited[[i]]) allLabels <- c(cc@className, names(cc@contains), "ANY") else allLabels <- cc@className labels <- outerLabels(labels, allLabels) } } if(!returnAll) labels <- labels[-1] # drop exact match labels <- unique(labels) # only needed while contains slot can have duplicates(!) allMethods <- objects(table, all.names=TRUE) found <- match(labels, allMethods, 0)>0 for(label in labels[found]) methods[[label]] <- get(label, envir = table) if(hasGroup) { ## add the group methods recursively found but each time ## only those not already included in found. groupmethods <- .getGroupMethods(labels, groupGenerics, found) fromGroup <- c(rep(0, length(methods)), rep(1, length(groupmethods))) methods <- c(methods, groupmethods) } else fromGroup <- rep(0, length(methods)) ## remove default if its not the only method if(length(methods)>1 && !returnAll) { defaultLabel <- paste(rep("ANY", nargs), collapse = "#") i <- match(defaultLabel, names(methods), 0) if(i > 0) { methods <- methods[-i] fromGroup <- fromGroup[-i] } } if(doExcluded) methods <- methods[is.na(match(names(methods), as.character(excluded)))] if(length(methods)>1 && !returnAll) { if(nargs == 1) classDefs <- list(def) ## else, defined before methods <- .getBestMethods(methods, classDefs, fromGroup) if(length(methods)>1) warning(gettextf("Ambiguous method selection for \"%s\", target \"%s\" (the first of the signatures shown will be used)\n%s\n", fdef@generic, .sigLabel(classes), paste(" ", names(methods), collapse = "\n"))) methods <- methods[1] } if(doMtable && length(methods)>0) { tlabel <- .sigLabel(classes) m <- methods[[1]] if(is(m, "MethodDefinition")) { # else, a primitive m@target <- .newSignature(classes, fdef@signature) methods[[1]] <- m } assign(tlabel, m, envir = mtable) } methods } .newSignature <- function(classes, names) { ## a simple version to deal with boostrapping stage i <- seq(length=min(length(classes), length(names))) value <- as.character(classes)[i] class(value) <- getClass("signature")@className value@names <- as.character(names)[i] value } .findNextFromTable <- function(method, f, optional, envir, prev = character()) { fdef <- getGeneric(f) env <- environment(fdef) target <- method@target n <- get(".SigLength", envir = env) defined <- method@defined m <- length(defined) if(m > n) length(defined) <- n else if(n > m) ## will only really need this to be a signature when the elements ## have package attribute--see .sigLabel defined <- new("signature", fdef, c(defined@.Data, rep("ANY", n-m))) excluded <- c(prev, .sigLabel(defined)) methods <- .findInheritedMethods(defined, fdef, mtable = NULL, excluded = excluded) if(length(methods)==0) # use default method, maybe recursively. methods <- list(finalDefaultMethod(fdef@default)) #todo: put a label on it? if(length(methods)>1) warning("found ", length(methods), " equally good next methods") #todo: better message ## excluded slot is a list, but with methods tables, elements are just labels new("MethodWithNext", method, nextMethod = methods[[1]], excluded =as.list(excluded)) } ## get the classes of the args .InheritForDispatch <- function(classes, fdef, mtable) { methods <- .findInheritedMethods(classes, fdef, mtable) if(length(methods)==1) return(methods[[1]]) # the method else if(length(methods)==0) { cnames <- paste("\"", sapply(classes, as.character), "\"", sep = "", collapse = ", ") stop("unable to find an inherited method for function \"", fdef@generic, "\", for signature ", cnames) } else stop("Internal error in finding inherited methods; didn't return a unique method") } .findMethodInTable <- function(signature, table, fdef = NULL) { allMethods <- objects(table, all.names=TRUE) if(is(fdef, "genericFunction")) signature <- .matchSigLength(signature, fdef, environment(fdef), FALSE) label <- .sigLabel(signature) found <- match(label, allMethods, 0) if(found>0) get(label, envir = table) else NULL } ## inheritance distances: 0 for the class, 1 for immediate contains, 2 for other contains ## and 3 for ANY .inhDistances <- function(classDef) { contains <- classDef@contains allNames <- unique(names(contains)) # bug allows duplicates in contains dist <- rep(2, length(allNames)) for(i in seq(along = dist)) { ci <- contains[[i]] dist[[i]] <- ci@distance } dist <- c(0, dist, NA) names(dist) <- c(classDef@className, allNames, "ANY") dist } .getBestMethods <- function(methods, classDefs, fromGroup) { n <- length(methods) dist <- rep(0, n) nArg <- length(classDefs) defClasses <- matrix("ANY", nArg, n) for(j in 1:n) { cl <- methods[[j]]@defined@.Data defClasses[1:length(cl),j] <- cl } containsDist <- vector("list", nArg) for(i in 1:nArg) containsDist[[i]] <- .inhDistances(classDefs[[i]]) maxDist <- max(unlist(containsDist), na.rm = TRUE) + 1 ## add up the inheritance distances for each argument (row of defClasses) for(i in 1:nArg) { ihi <- containsDist[[i]] ihi[is.na(ihi)] <- maxDist cli <- defClasses[i,] dist <- dist + ihi[match(cli, names(ihi))] } best <- dist ==min(dist) ## of the least distance methods, choose direct, rather than group ## methods, unless all the best methods are from group generics if(!all(fromGroup[best])) best <- best & !fromGroup methods[best] } # add objects to the generic function's environment that allow # table-based dispatch of methods .setupMethodsTables <- function(generic, initialize = !exists(".Methods", envir = env, inherits = FALSE)) { env <- environment(generic) if(initialize) mlist <- generic@default else mlist <- get(".Methods", envir = env, inherits = FALSE) if(initialize || !exists(".SigLength", envir = env, inherits = FALSE)) assign(".SigLength", 1, envir = env) ## check that groups of generics agree on .SigLength; otherwise ## labels won't match argSyms <- lapply(generic@signature, as.name) assign(".SigArgs", argSyms, envir = env) mtable <- .mlistAddToTable(generic, mlist) assign(".MTable", mtable, envir = env) .resetInheritedMethods(env, mtable) } .updateMethodsInTable <- function(generic, where, attach) { fenv <- environment(generic) reset <- identical(attach, "reset") if(!exists(".MTable", envir = fenv, inherits = FALSE)) .setupMethodsTables(generic) mtable <- get(".MTable", envir = fenv) if(!reset) { env <- as.environment(where) tname <- .TableMetaName(generic@generic, generic@package) if(exists(tname, envir = env, inherits = FALSE)) { .mergeMethodsTable(generic, mtable, get(tname, envir = env), attach) } else { warning(gettextf( "Couldn't find methods table for \"%s\", package \"%s\" may be out of date", generic@generic, generic@package)) metaName <- mlistMetaName(generic) if(exists(metaName, envir = env, inherits = FALSE)) .mlistAddToTable(generic, get(metaName, envir = env), mtable, attach) else warning("Methods list for generic \"", generic@generic, "\" not found") } } if(length(generic@group)>0) { groups <- as.list(generic@group) generics <- vector("list", length(groups)) for(i in 1:length(groups)) generics[[i]] <- getGeneric(groups[[i]]) .checkGroupSigLength(groups, generics) } else if(is(generic, "groupGenericFunction")) .checkGroupSigLength(list(generic@generic), list(generic)) .resetInheritedMethods(fenv, mtable) mtable } .resetInheritedMethods <- function(fenv, mtable) { allObjects <- character() direct <- objects(mtable, all=TRUE) if(exists(".AllMTable", envir = fenv, inherits = FALSE)) { ## remove all inherited methods. Note that code (e.g. setMethod) that asigns ## a new method to mtable is responsible for copying it to allTable as well. allTable <- get(".AllMTable", envir = fenv) allObjects <- objects(allTable, all=TRUE) remove(list= allObjects[is.na(match(allObjects, direct))], envir = allTable) } else { allTable <- new.env(TRUE, fenv) assign(".AllMTable", allTable, envir = fenv) } ## check for missing direct objects; usually a non-existent AllMTable? if(any(is.na(match(direct, allObjects)))) { direct <- objects(mtable, all=TRUE) for(what in direct) assign(what, get(what, envir = mtable), envir = allTable) } } .UseMethodsTables <- TRUE .UsingMethodsTables <- function(onOff = .UseMethodsTables, where = .methodsNamespace) { prev <- .UseMethodsTables if(nargs()) { onOff <- as.logical(onOff) if(identical(onOff, TRUE) || identical(onOff, FALSE)) .assignOverBinding(".UseMethodsTables", onOff, where = where, FALSE) else stop(gettextf("Invalid argument to .UsingMethodsTables: must be TRUE or FALSE %s", onOff)) } prev } .showMethodsTable <- function(generic, includeDefs = FALSE, inherited = FALSE, classes = NULL, showEmpty = TRUE, printTo = stdout()) { cf <- function(...) cat(file = printTo, sep = "", ...) sigString <- function(sig) paste(sig@names, "=\"", as.character(sig), "\"", sep = "", collapse = ", ") qs <- function(what) paste('"', what, '"', collapse = ", ", sep = "") doFun <- function(func, pkg) cf("Function: ", func, " (package ", pkg, ")\n") env <- environment(generic) signature = generic@signature table <- get(if(inherited) ".AllMTable" else ".MTable", envir = env) f <- generic@generic p <- packageSlot(f) if(is.null(p)) p <- "base" deflt <- new("signature", generic, "ANY") labels <- objects(table, all = TRUE) if(!is.null(classes) && length(labels) > 0) { sigL <- strsplit(labels, split = "#") keep <- !sapply(sigL, function(x, y) all(is.na(match(x, y))), classes) labels <- labels[keep] } if(length(labels) == 0) { if(showEmpty) { doFun(f,p) cf("\n\n") } return(invisible()) } ## else: non-empty methods list doFun(f,p) for(what in labels) { m <- get(what, envir = table) if( is(m, "MethodDefinition")) { t <- m@target if(length(t) == 0) t <- deflt d <- m@defined if(length(d) == 0) d <- deflt cf(sigString(t), "\n") if(!identical(t, d)) cf(" (inherited from: ", sigString(d), ")\n") if(!.identC(m@generic, f) && length(m@generic) == 1 && nchar(m@generic)>0) cf(" (definition from function \"", m@generic, "\")\n") } if(includeDefs) { if(is(m, "MethodDefinition")) m <- m@.Data cat(deparse(m), sep="\n", "\n", file = printTo) } } cat("\n", file = printTo) } ## temporary switch for tables useMTable <- function(onOff = NA) .Call("R_set_method_dispatch", as.logical(onOff), PACKAGE = "methods") ## get all the group generic functions, in breadth-first order since ## direct group inheritance is closer than indirect (all existing ## groups are mutually exclusive, but multiple group membership is ## allowed) .getAllGroups <- function(funs) { start <- length(funs) for(i in seq(along = funs)) { groups <- funs[[i]]@group funs <- c(funs, lapply(groups, function(what) { f <- getGeneric(what) if(!is.function(f)) stop("Failed to find expected group generic function: ", what) f })) } # now the next generations recusively if(length(funs) > start) { nmore <- length(funs) - start more <- Recall(funs[(start+1):length(funs)]) ## did we add any groups? if(length(more) > nmore) funs <- c(funs, more[(nmore+1):length(more)]) } funs } .getGroupMethods <- function(labels, generics, found) { methods <- list() for(i in seq(along = generics)) { gen <- generics[[i]] if(!is(gen,"genericFunction")) stop("Invalid group generic function in search for inherited method (class \"", class(gen), "\"") table <- .getMethodsTable(gen) allMethods <- objects(table, all.names = TRUE) ## TODO: possible for .SigLength to differ between group & ## members. Requires expanding labels to max. length newFound <- rep(FALSE, length(found)) newFound[!found] <- (match(labels[!found], allMethods, 0)>0) found <- found | newFound for(what in labels[newFound]) methods[[what]] <- get(what, envir = table) } methods } .getMethodsTable <- function(fdef, env = environment(fdef), check = TRUE, inherited = FALSE) { if(inherited) name <- ".AllMTable" else name <- ".MTable" if(check && !exists(name, envir = env, inherits = FALSE)) .setupMethodsTables(fdef) get(name, envir = env) } .getGenericSigLength <- function(fdef, env = environment(fdef), check = TRUE) { if(check && !exists(".SigLength", envir = env, inherits = FALSE)) .setupMethodsTables(fdef) get(".SigLength", envir = env) } .checkGroupSigLength <- function(gnames, generics = lapply(gnames, getGeneric)) { funs <- gnames recall <- FALSE for(i in seq(along = gnames)) { what <- gnames[[i]] fdef <- generics[[i]] if(!is(fdef, "groupGenericFunction")) { warning("Trying to check signature length of group generic \"", what, "\", but it is not a group generic") next } if(length(fdef@group) > 0) {# push up the check one level gnames[[i]] <- fdef@group generics[[i]] <- lapply(fdef@group, getGeneric) recall <- TRUE next } funs <- c(funs, getGroupMembers(fdef, TRUE, FALSE)) } if(recall) return(Recall(unlist(gnames, FALSE), unlist(generics, FALSE))) funs <- unique(funs) fdefs <- lapply(funs, function(x) { if(is.character(x) && length(x) == 1) getGeneric(x) else x}) ## now compare the sig lengths sigs <- rep(0,length(funs)) for(i in seq(along = sigs)) { what <- funs[[i]] fdef <- fdefs[[i]] if(is.null(fdef)) next # getGroupMembers returns NULL if member is not defined if(!is(fdef, "genericFunction")) warning("Trying to check signature length of generic \"", what, "\", but it is not a generic function: i = ", i, ", funs = ", paste(unlist(funs), collapse = ", "), "; gnames = ", paste(as.character(gnames), collapse = ", ")) else { ev <- environment(fdef) if(!exists(".SigLength", envir = ev, inherits = FALSE)) .setupMethodsTables(fdef) sigs[i] <- get(".SigLength", envir = ev) } } n <- max(sigs) reset <- sigs < n & sigs >0 # all the sigs for defined funs & less than max. if(any(reset)) { funs <- funs[reset] fdefs <- fdefs[reset] for(fdef in fdefs) { .resetSigLength(fdef, n) } } funs } ## a simplified outer of paste outerLabels <- function(labels, new) { ## WARNING: This code incorporates the definition of .sigLabel ## and so must change if that does (e.g. to include package) n <- length(labels) m <- length(new) paste(labels[rep(1:n, rep(m,n))], new[rep(1:m,n)], sep ="#") } .matchSigLength <- function(sig, fdef, fenv, reset = FALSE) { nargs <- .getGenericSigLength(fdef, fenv, TRUE) n <- length(sig) if(n < nargs) sig <- c(as.character(sig), rep("ANY", nargs - n)) else if(n > nargs) { #reset table? if(all(sig[(nargs+1):n] == "ANY")) length(sig) <- nargs else { while(sig[[n]] == "ANY") n <- n-1 if(reset) .resetSigLength(fdef, n) length(sig) <- n } } sig } .resetSigLength <- function(fdef, n) { fenv <- environment(fdef) assign(".SigLength", n, envir = fenv) mtable <- .getMethodsTable(fdef, fenv, check = FALSE) signames <- fdef@signature length(signames) <- n .resetTable(mtable, n, signames) .resetInheritedMethods(fenv, mtable) } .TableMetaName <- function(name, package) methodsPackageMetaName("T", paste(name, package, sep=":")) .TableMetaPrefix <- function() methodsPackageMetaName("T","") .addToMetaTable <- function(fdef, signature, definition, where, nSig) { return() } # the real version ..addToMetaTable <- function(fdef, signature, definition, where, nSig = .getGenericSigLength(fdef, fenv)) { # TODO: nSig should be a slot in the table tname <- .TableMetaName(fdef@generic, fdef@package) where <- as.environment(where) if(exists(tname, envir =where, inherits = FALSE)) { table <- get(tname, envir = where) if(length(signature) > nSig) .resetTable(table, length(signature), fdef@signature[1:length(signature)]) } else { table <- new.env(TRUE, environment(fdef)) assign(tname, table, envir = where) } assign(.sigLabel(signature), definition, envir = table) } .makeGenericTables <- function(where) { generics <- .getGenerics(where) mtables <- .getGenerics(where, FALSE) for(i in seq(along = generics)) { name <- generics[[i]] mtable <- get(mtables[[i]], envir = where) generic <- .getGeneric(name, where = where) if(is.null(generic)) { warning(gettextf( "Could not find generic function \"%s\" to initialize cached methods", name)) next } table <- .getMethodsTable(generic) .mergeMethodsTable(generic, table, mtable) assign(.TableMetaName(generic@generic, generic@package), table, envir = where) } } .assignMethodsMetaTable <- function(mlist, generic, where, overwrite = TRUE) { tname <- .TableMetaName(generic@generic, generic@package) if(overwrite || !exists(tname, envir = where, inherits = FALSE)) { table <- .mlistAddToTable(generic, mlist) assign(tname, table, envir = where) } }