| # File src/library/methods/R/MethodsList.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2018 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| MethodsList <- |
| ## Create a MethodsList object out of the arguments. |
| ## |
| ## Conceptually, this object is a named collection of methods to be |
| ## dispatched when the (first) argument in a function call matches the |
| ## class corresponding to one of the names. A final, unnamed element |
| ## (i.e., with name `""') corresponds to the default method. |
| ## |
| ## The elements can be either a function, or another MethodsList. In |
| ## the second case, this list implies dispatching on the second |
| ## argument to the function using that list, given a selection of this |
| ## element on the first argument. Thus, method dispatching on an |
| ## arbitrary number of arguments is defined. |
| ## |
| ## MethodsList objects are used primarily to dispatch OOP-style |
| ## methods and, in R, to emulate S4-style methods. |
| function(.ArgName, ...) |
| { |
| .MlistDeprecated("MethodsList()") |
| value <- makeMethodsList(list(...)) |
| if(is.name(.ArgName)){} |
| else if(is.character(.ArgName) && length(.ArgName) == 1) |
| .ArgName <- as.name(.ArgName) |
| else stop("invalid first argument: should be the name of the first argument in the dispatch") |
| slot(value, "argument") <- .ArgName |
| value |
| } |
| |
| makeMethodsList <- function(object, level=1) |
| { |
| .MlistDeprecated("makeMethodsList()") |
| mnames <- allNames(object) |
| if(.noMlists()) { |
| keep <- mnames %in% c("", "ANY") |
| mnames <- mnames[keep] |
| object <- object[keep] |
| } |
| value <- new("MethodsList") |
| i <- match("", mnames) |
| if(!is.na(i)) { |
| ## convert to ANY |
| mnames[[i]] <- "ANY" |
| names(object) <- mnames |
| } |
| if(anyDuplicated(mnames)) |
| stop(gettextf("duplicate element names in 'MethodsList' at level %d: %s", |
| level, paste("\"", unique(mnames[duplicated(mnames)]), "\"", |
| collapse=", ")), domain = NA) |
| for(i in seq_along(object)) { |
| eli <- object[[i]] |
| if(is.function(eli) |
| || is(eli, "MethodsList")) {} |
| else if(is(eli, "list") || |
| is(eli, "named")) |
| object[[i]] <- Recall(eli, NULL, level+1) |
| else |
| stop(gettextf("element %d at level %d (class %s) cannot be interpreted as a function or named list", |
| i, level, dQuote(class(eli))), |
| domain = NA) |
| } |
| slot(value, "methods") <- object |
| value |
| } |
| |
| SignatureMethod <- |
| ## construct a MethodsList object containing (only) this method, corresponding |
| ## to the signature; i.e., such that signature[[1L]] is the match for the first |
| ## argument, signature[[2L]] for the second argument, and so on. The string |
| ## "missing" means a match for a missing argument, and "ANY" means use this as the |
| ## default setting at this level. |
| ## |
| ## The first argument is the argument names to be used for dispatch corresponding to |
| ## the signatures. |
| function(names, signature, definition) |
| { |
| .MlistDeprecated("SignatureMethod()") |
| n <- length(signature) |
| if(n > length(names)) |
| stop("arguments 'names' and 'signature' must have the same length") |
| if(n == 0) |
| return(definition) |
| Class <- signature[[n]] |
| name <- names[[n]] |
| m <- MethodsList(name) |
| slot(m, "methods")[[Class]] <- definition |
| slot(m, "argument") <- as.name(name) |
| SignatureMethod(names[-n], signature[-n], m) |
| } |
| |
| |
| insertMethod <- |
| ## insert the definition `def' into the MethodsList object, `mlist', corresponding to |
| ## the signature, and return the modified MethodsList. |
| function(mlist, signature, args, def, cacheOnly = FALSE) |
| { |
| .MlistDeprecated("insertMethod()") |
| if(.noMlists() && !identical(unique(signature), "ANY")) |
| return(mlist) |
| ## Checks for assertions about valid calls. |
| ## See rev. 1.17 for the code before the assertions added. |
| if(identical(args[1L], "...") && !identical(names(signature), "...")) { |
| if(identical(signature[[1L]], "ANY")) |
| stop(gettextf("inserting method with invalid signature matching argument '...' to class %s", |
| dQuote(signature[[1L]])), |
| domain = NA) |
| args <- args[-1L] |
| signature <- signature[-1L] |
| if(length(signature) == 0L) |
| return(mlist) |
| } |
| if(length(signature) == 0L) |
| stop("inserting method corresponding to empty signature") |
| if(!is(mlist, "MethodsList")) |
| stop(gettextf("inserting method into non-methods-list object (class %s)", |
| dQuote(.class1(mlist))), |
| domain = NA) |
| if(length(args) > 1 && !cacheOnly) |
| mlist <- balanceMethodsList(mlist, args) |
| Class <- signature[[1]] |
| methods <- if(cacheOnly) mlist@allMethods else mlist@methods |
| current <- methods[[Class]] |
| if(is(current, "MethodsList")) { |
| nextArg <- as.character(current@argument) |
| sigArgs <- args |
| n <- length(signature) |
| length(sigArgs) <- n |
| if(is.na(match(nextArg, sigArgs))) { |
| n <- match(nextArg, args) - n |
| if(is.na(n)) { ## not in args eitiher |
| n <- 1 |
| args <- c(args, nextArg) |
| } |
| ## make explicit the trailing ANY's needed |
| signature <- c(signature, rep("ANY", n)) |
| } |
| } |
| if(length(signature) == 1) { |
| if(is.null(current)) { |
| if(!is.null(def)) |
| methods[[Class]] <- def |
| ## else, no change |
| } |
| else { |
| which <- match(Class, names(methods)) |
| if(is.null(def)) |
| ## delete the method |
| methods <- methods[-which] |
| else |
| methods[[which]] <- def |
| } |
| } |
| else { ## recursively merge, initializing current if necessary |
| if(is.null(current)) |
| current <- new("MethodsList", argument = as.name(args[2L])) |
| else if(is.function(current)) |
| current <- new("MethodsList", argument = as.name(args[2L]), |
| methods = list(ANY = current)) |
| methods[[Class]] <- |
| Recall(current, signature[-1L], args[-1L], def, cacheOnly) |
| } |
| mlist@allMethods <- methods |
| if(!cacheOnly) |
| mlist@methods <- methods |
| mlist |
| } |
| |
| |
| MethodsListSelect <- |
| ## select the element of a MethodsList object corresponding to the |
| ## actual arguments (as defined in the suppled environment), |
| ## and return the object, extended to include that method if necessary. |
| ## |
| ## Works recursively. At each level finds an argument name from the current `mlist' |
| ## object, and evaluates this argument (if it is not missing), then uses the |
| ## class of the result to select an element of `mlist'. If such an element |
| ## exists and is another `MethodsList' object, `MethodsListSelect' calls itself recursively |
| ## to resolve using further arguments. Matching includes using a default selection or |
| ## a method specifically linked to class `"missing"'. Once a function is found, it |
| ## is returned as the value. If matching fails, NULL is returned. |
| function(f, env, |
| mlist = NULL, |
| fEnv = if(is(fdef, "genericFunction")) environment(fdef) else baseenv(), |
| finalDefault = finalDefaultMethod(mlist), |
| evalArgs = TRUE, |
| useInherited = TRUE, ## supplied when evalArgs is FALSE |
| fdef = getGeneric(f, where = env), # MUST BE SAFE FROM RECUSIVE METHOD SELECTION |
| resetAllowed = TRUE # FALSE when called from selectMethod, .findNextMethod |
| ) |
| { |
| .MlistDeprecated("MethodsListSelect()") |
| if(!resetAllowed) # ensure we restore the real methods for this function |
| resetMlist <- .getMethodsForDispatch(fdef) |
| ## look for call from C dispatch code during another call to MethodsListSelect |
| if(is.null(f)) {} # Recall, not from C |
| else { |
| fMethods <- .getMethodsForDispatch(fdef) |
| if(is.null(mlist) || (evalArgs && is.function(fMethods))) |
| mlist <- fMethods |
| } |
| resetNeeded <- .setIfBase(f, fdef, mlist) # quickly protect against recursion -- see Methods.R |
| if(resetNeeded) { |
| on.exit(.setMethodsForDispatch(f, fdef, mlist)) |
| } |
| if(!is(mlist, "MethodsList")) { |
| if(is.function(mlist)) # call to f, inside MethodsListSelect |
| {on.exit(); return(mlist)} |
| if(is.null(f)) # recursive recall of MethodsListSelect |
| stop("invalid method sublist") |
| else if(!is.null(mlist)) # NULL => 1st call to genericFunction |
| stop(gettextf("%f is not a valid generic function: methods list was an object of class %s", |
| sQuote(f), dQuote(class(mlist))), |
| domain = NA) |
| } |
| if(!is.logical(useInherited)) |
| stop(gettextf("%s must be TRUE, FALSE, or a named logical vector of those values; got an object of class %s", |
| sQuote("useInherited"), |
| dQuote(class(useInherited))), |
| domain = NA) |
| if(identical(mlist, .getMethodsForDispatch(fdef))) { |
| resetNeeded <- TRUE |
| ## On the initial call: |
| ## turn off any further method dispatch on this function, to avoid recursive |
| ## loops if f is a function used in MethodsListSelect. |
| ## TODO: Using namespaces in the methods package would eliminate the need for this |
| .setMethodsForDispatch(f, fdef, finalDefault) |
| if(is(mlist, "MethodsList")) { |
| on.exit(.setMethodsForDispatch(f, fdef, mlist)) |
| } |
| } |
| argName <- slot(mlist, "argument") |
| arg <- NULL ## => don't use instance-specific inheritance |
| if(evalArgs) { |
| ## check for missing argument. NB: S sense, not that of R base missing() |
| if(missingArg(argName, env, TRUE)) |
| thisClass <- "missing" |
| else { |
| arg <- eval(as.name(argName), env) ## DO use instance-specific inheritance |
| if(missing(arg)) ## S3 weird R code? Bail out! |
| return(finalDefault) |
| thisClass <- .class1(arg) |
| } |
| } |
| else |
| thisClass <- get(as.character(argName), envir = env, inherits = FALSE) |
| if(isTRUE(useInherited) || isFALSE(useInherited)) |
| thisInherit <- nextUseInherited <- useInherited |
| else { |
| which <- match(as.character(argName), names(useInherited)) |
| if(is.na(which)) { |
| nextUseInherited <- useInherited |
| thisInherit <- TRUE |
| } |
| else { |
| thisInherit <- useInherited[[which]] |
| nextUseInherited <- useInherited[-which] |
| } |
| } |
| fromClass <- thisClass ## will mark the class actually providing the method |
| allMethods <- mlist@allMethods |
| which <- match(thisClass, names(allMethods)) |
| inherited <- is.na(which) |
| selection <- if(inherited) NULL else allMethods[[which]] |
| if(!inherited) { |
| if(is.function(selection)) { |
| if(is.null(f)) { |
| ## An inherited method at the next level up. |
| ## only the inherited method should be added |
| mlist <- .trimMlist(mlist, fromClass) |
| } |
| value <- mlist ## no change |
| } |
| else { |
| ## recursive call with NULL function name, to allow search to fail & |
| ## to suppress any reset actions. |
| method <- Recall(NULL, env, selection, finalDefault = finalDefault, |
| evalArgs = evalArgs, useInherited = nextUseInherited, fdef = fdef, |
| ) |
| if(is(method, "EmptyMethodsList")) |
| value <- method |
| else { |
| mlist@allMethods[[which]] <- method |
| value <- mlist |
| } |
| } |
| } |
| if(inherited || is(value, "EmptyMethodsList")) { |
| ## direct selection failed at this level or below |
| method <- NULL |
| if(thisInherit) { |
| allSelections <- inheritedSubMethodLists(arg, fromClass, mlist, env) |
| allClasses <- names(allSelections) |
| for(i in seq_along(allSelections)) { |
| selection <- allSelections[[i]] |
| fromClass <- allClasses[[i]] |
| if(is.function(selection)) |
| method <- selection |
| else if(is(selection, "MethodsList")) { |
| ## go on to try matching further arguments |
| method <- Recall(NULL, env, selection, finalDefault = finalDefault, |
| evalArgs = evalArgs, |
| useInherited = nextUseInherited, fdef = fdef) |
| if(is(method, "EmptyMethodsList")) |
| selection <- method ## recursive selection failed |
| } |
| if(!is(selection, "EmptyMethodsList")) |
| break |
| } |
| } |
| if((is.null(selection) || is(selection, "EmptyMethodsList")) |
| && !is.null(f) && !is.null(finalDefault)) { |
| ## only use the final default method after exhausting all |
| ## other possibilities, at all levels. |
| method <- finalDefault |
| fromClass <- "ANY" |
| } |
| if(is.null(method) || is(method, "EmptyMethodsList")) |
| value <- emptyMethodsList(mlist, thisClass) ## nothing found |
| else { |
| method <- MethodAddCoerce(method, argName, thisClass, fromClass) |
| value <- .insertCachedMethods(mlist, as.character(argName), thisClass, fromClass, |
| method) |
| } |
| } |
| if(!is.null(f)) { |
| ## top level |
| if(is(value, "EmptyMethodsList")) ## selection failed |
| value <- NULL |
| if(resetNeeded) { |
| on.exit() # cancel the restore of the original mlist |
| if(resetAllowed) { |
| if(is.null(value)) resetMlist <- mlist else resetMlist <- value |
| } |
| .setMethodsForDispatch(f, fdef, resetMlist) |
| if(dispatchIsInternal(fdef)) |
| setPrimitiveMethods(f, finalDefault, "set", fdef, resetMlist) |
| } |
| |
| } |
| value |
| } |
| |
| emptyMethodsList <- function(mlist, thisClass = "ANY", sublist = list()) { |
| .MlistDeprecated("emptyMethodsList()") |
| sublist[thisClass] <- list(NULL) |
| new("EmptyMethodsList", argument = mlist@argument, sublist = sublist) |
| } |
| |
| insertMethodInEmptyList <- function(mlist, def) { |
| .MlistDeprecated("insertMethodInEmptyList()") |
| value <- new("MethodsList", argument = mlist@argument) |
| sublist <- mlist@sublist |
| submethods <- sublist[[1L]] |
| if(is.null(submethods)) |
| sublist[[1L]] <- def |
| else |
| sublist[[1L]] <- Recall(submethods, def) |
| value@allMethods <- sublist |
| value |
| } |
| |
| |
| |
| |
| finalDefaultMethod <- |
| ## Return the default method from the generic (it may be NULL, a method object or a primitive. |
| ## this previously searched in a MethodsList object. Once those are gone, the loop should |
| ## be irrelevant except as an error check. |
| function(method) |
| { |
| repeat { |
| if(is.function(method) # <- somewhat liberal, but catches both methods and primitives |
| || is.null(method)) |
| break |
| if(is(method, "MethodsList")) { |
| .MlistDeprecated() |
| method <- slot(method, "methods")[["ANY"]] |
| } else |
| stop(gettextf( |
| "default method must be a method definition, a primitive or NULL: got an object of class %s", |
| dQuote(class(method))), |
| domain = NA) |
| } |
| method |
| } |
| |
| |
| inheritedSubMethodLists <- |
| ## Utility function to match the object to the elements of a methods list. |
| ## |
| ## The function looks only for an inherited match, and only among |
| ## the methods that are not themselves inherited. (Inherited methods when found are |
| ## stored in the session copy of the methods list, but they themselves should not be |
| ## used for finding inherited matches, because an erroneous match could be found depending |
| ## on which methods were previously used. See the detailed discussion of methods.) |
| function(object, thisClass, mlist, ev) |
| { |
| .MlistDeprecated("inheritedSubMethodLists()") |
| methods <- slot(mlist, "methods")## only direct methods |
| defaultMethod <- methods[["ANY"]]## maybe NULL |
| classes <- names(methods) |
| value <- list() |
| if(.identC(thisClass, "missing")) { |
| ## no superclasses for "missing" |
| } |
| else { |
| ## search in the superclasses, but don't use inherited methods |
| ## There are two cases: if thisClass is formally defined & unsealed, use its |
| ## superclasses. Otherwise, look in the subclasses of those classes for |
| ## which methods exist. |
| classDef <- getClassDef(thisClass, ev) |
| useSuperClasses <- !is.null(classDef) && !classDef@sealed |
| if(useSuperClasses) { |
| ## for consistency, order the available methods by |
| ## the ordering of the superclasses of thisClass |
| superClasses <- names(classDef@contains) |
| classes <- superClasses[!is.na(match(superClasses, classes))] |
| for(which in seq_along(classes)) { |
| tryClass <- classes[[which]] |
| ## TODO: There is potential bug here: If the is relation is conditional, |
| ## we should not cache this selection. Needs another trick in the environment |
| ## to FORCE no caching regardless of what happens elsewhere; e.g., storing a |
| ## special object in .Class |
| if(is.null(object) || is(object, tryClass)) { |
| value[[tryClass]] <- methods[[tryClass]] |
| } |
| } |
| } |
| else { |
| for(which in seq_along(classes)) { |
| tryClass <- classes[[which]] |
| tryClassDef <- getClassDef(tryClass, ev) |
| if(!is.null(tryClassDef) && |
| !is.na(match(thisClass, names(tryClassDef@subclasses)))) |
| value[[tryClass]] <- methods[[which]] |
| } |
| } |
| } |
| if(!is.null(defaultMethod)) |
| value[["ANY"]] <- defaultMethod |
| value |
| } |
| |
| |
| matchSignature <- |
| ## Match the signature object (a partially or completely named subset of the |
| ## arguments of `fun', and return a vector of all the classes in the order specified |
| ## by the signature slot of the generic. The classes not specified by `signature |
| ##' will be `"ANY"' in the value. |
| function(signature, fun, where = baseenv()) |
| { |
| if(!is(fun, "genericFunction")) |
| stop(gettextf("trying to match a method signature to an object (of class %s) that is not a generic function", |
| dQuote(class(fun))), |
| domain = NA) |
| anames <- fun@signature |
| if(length(signature) == 0L) |
| return(character()) |
| 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", |
| dQuote(class(signature))), |
| domain = NA) |
| if(!identical(where, baseenv())) { |
| ## 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 |
| MSG <- if(identical(as.vector(coerce@generic), "coerce") && |
| length(unknown) == 1) message |
| else function(...) warning(..., call. = FALSE) |
| MSG(.renderSignature(fun@generic, signature), |
| sprintf(ngettext(length(unknown), |
| "no definition for class %s", |
| "no definition for classes %s"), |
| paste(dQuote(unknown), collapse = ", ")), |
| domain = NA) |
| } |
| } |
| signature <- as.list(signature) |
| if(length(sigClasses) != length(signature)) |
| stop(gettextf("object to use as a method signature for function %s does not look like a legitimate signature (a vector of single class names): there were %d class names, but %d elements in the signature object", |
| sQuote(fun@generic), |
| length(sigClasses), |
| length(signature)), |
| domain = NA) |
| if(is.null(names(signature))) { |
| which <- seq_along(signature) |
| if(length(which) > length(anames)) |
| stop(gettextf("more elements in the method signature (%d) than in the generic signature (%d) for function %s", |
| length(which), length(anames), sQuote(fun@generic)), domain = NA) |
| } |
| else { |
| ## construct a function call with the same naming pattern & |
| ## values as signature |
| sigList <- signature |
| for(i in seq_along(sigList)) |
| sigList[[i]] <- c(sigClasses[[i]], pkgs[[i]]) |
| fcall <- do.call("call", c("fun", sigList)) |
| ## match the call to the formal signature (usually the formal args) |
| if(identical(anames, formalArgs(fun))) |
| smatch <- match.call(fun, fcall) |
| else { |
| fmatch <- fun |
| ff <- as.list(anames); names(ff) <- anames |
| formals(fmatch, envir = environment(fun)) <- ff |
| smatch <- match.call(fmatch, fcall) |
| } |
| snames <- names(smatch)[-1L] |
| which <- match(snames, anames) |
| ## Assertion: match.call has permuted the args into the order of formal args, |
| ## and carried along the values. Get the supplied classes in that |
| ## order, from the matched args in the call object. |
| if(anyNA(which)) |
| stop(sprintf(ngettext(sum(is.na(which)), |
| "in the method signature for function %s invalid argument name in the signature: %s", |
| "in the method signature for function %s invalid argument names in the signature: %s"), |
| sQuote(fun@generic), |
| paste(snames[is.na(which)], collapse = ", ")), |
| domain = NA) |
| smatch <- smatch[-1] |
| for(i in seq_along(smatch)) { |
| eli <- smatch[[i]] |
| sigClasses[[i]] <- eli[[1]] |
| pkgs[[i]] <- eli[[2]] |
| } |
| } |
| 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) <- 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 |
| } |
| |
| showMlist <- |
| ## Prints the contents of the MethodsList. If `includeDefs' the signatures and the |
| ## corresponding definitions will be printed; otherwise, only the signatures. |
| ## |
| ## If `includeDefs' is `TRUE', the currently known inherited methods are included; |
| ## otherwise, only the directly defined methods. |
| function(mlist, includeDefs = TRUE, inherited = TRUE, classes = NULL, useArgNames = TRUE, |
| printTo = stdout()) |
| { |
| .MlistDeprecated("showMlist()") |
| if(isFALSE(printTo)) { |
| tmp <- tempfile() |
| con <- file(tmp, "w") |
| } |
| else |
| con <- printTo |
| object <- linearizeMlist(mlist, inherited) |
| methods <- object@methods |
| signatures <- object@classes |
| args <- object@arguments |
| if(!is.null(classes) && length(signatures)>0) { |
| keep <- !vapply(signatures, function(x, y) all(is.na(match(x, y))), NA, classes) |
| methods <- methods[keep] |
| signatures <- signatures[keep] |
| args <- args[keep] |
| } |
| if(length(methods) == 0) |
| cat(file=con, "<Empty Methods List>\n") |
| else { |
| n <- length(methods) |
| labels <- character(n) |
| if(useArgNames) { |
| for(i in 1L:n) { |
| sigi <- signatures[[i]] |
| labels[[i]] <- paste0(args[[i]], " = \"", sigi, "\"", |
| collapse = ", ") |
| } |
| } |
| else { |
| for(i in 1L:n) |
| labels[[i]] <- paste(signatures[[i]], collapse = ", ") |
| } |
| for(i in seq_along(methods)) { |
| cat(file=con, (if(includeDefs) "## Signature:" else ""), labels[[i]]) |
| method <- methods[[i]] |
| if(includeDefs) { |
| cat(file=con, ":\n") |
| if(is(method, "MethodDefinition")) ## really an assertion |
| cat(file=con, deparse(method@.Data), sep="\n") |
| else |
| cat(file=con, deparse(method), sep="\n") |
| } |
| if(is(method, "MethodDefinition") && |
| !identical(method@target, method@defined)) { |
| defFrom <- method@defined |
| cat(file = con, if(includeDefs) "##:" else "\n", |
| " (inherited from ", |
| paste0(names(defFrom), " = \"", |
| as.character(defFrom), "\"", |
| collapse = ", "), |
| ")", if(includeDefs) "\n", sep="") |
| } |
| cat(file=con, "\n") |
| } |
| } |
| if(isFALSE(printTo)) { |
| close(con) |
| value <- readLines(tmp) |
| unlink(tmp) |
| value |
| } |
| } |
| |
| promptMethods <- function(f, filename = NULL, methods) |
| { |
| ## Generate information in the style of 'prompt' for the methods of |
| ## the generic named 'f'. |
| ## |
| ## 'filename' can be a logical or NA or the name of a file to print |
| ## to. If it 'FALSE', the methods skeleton is returned, to be |
| ## included in other printing (typically, the output from 'prompt'). |
| |
| escape <- function(txt) gsub("%", "\\\\%", txt) |
| packageString <- "" |
| |
| fdef <- getGeneric(f) |
| if(!isGeneric(f, fdef=fdef)) |
| stop(gettextf("no generic function found corresponding to %s", |
| sQuote(f)), |
| domain = NA) |
| if(missing(methods)) { |
| methods <- findMethods(fdef) |
| ## try making packageString |
| where <- .genEnv(fdef, topenv(parent.frame())) |
| if(!identical(where, .GlobalEnv)) |
| packageString <- |
| sprintf("in Package \\pkg{%s}", getPackageName(where)) |
| } |
| fullName <- utils:::topicName("methods", f) |
| n <- length(methods) |
| labels <- character(n) |
| aliases <- character(n) |
| signatures <- findMethodSignatures(methods = methods, target=TRUE) |
| args <- colnames(signatures) # the *same* for all |
| for(i in seq_len(n)) { |
| sigi <- signatures[i, ] |
| labels[[i]] <- |
| sprintf("\\code{signature(%s)}", |
| paste(sprintf("%s = \"%s\"", args, escape(sigi)), |
| collapse = ", ")) |
| aliases[[i]] <- |
| paste0("\\alias{", |
| utils:::topicName("method", c(f, signatures[i,])), |
| "}") |
| } |
| text <- paste0("\n\\item{", labels, |
| "}{\n%% ~~describe this method here~~\n}") |
| text <- c("\\section{Methods}{\n\\describe{", text, "}}") |
| aliasText <- c(paste0("\\alias{", escape(fullName), "}"), escape(aliases)) |
| if(isFALSE(filename)) |
| return(c(aliasText, text)) |
| |
| if(is.null(filename) || isTRUE(filename)) |
| filename <- paste0(fullName, ".Rd") |
| |
| Rdtxt <- |
| list(name = paste0("\\name{", fullName, "}"), |
| type = "\\docType{methods}", |
| aliases = aliasText, |
| ## <FIXME> |
| ## Title and description are ok as auto-generated: should |
| ## they be flagged as such (via '~~' which are quite often |
| ## left in by authors)? |
| title = |
| sprintf("\\title{ ~~ Methods for Function \\code{%s} %s ~~}", |
| f, packageString), |
| description = |
| paste0("\\description{\n ~~ Methods for function", |
| " \\code{", f, "} ", |
| sub("^in Package", "in package", packageString), |
| " ~~\n}"), |
| ## </FIXME> |
| "section{Methods}" = text, |
| keywords = c("\\keyword{methods}", |
| "\\keyword{ ~~ other possible keyword(s) ~~ }")) |
| |
| if(is.na(filename)) return(Rdtxt) |
| |
| cat(unlist(Rdtxt), file = filename, sep = "\n") |
| .message("A shell of methods documentation has been written", |
| .fileDesc(filename), ".\n") |
| invisible(filename) |
| } |
| |
| ##' only called from showMlist() above, which has been deprecated in R 3.2.0 (Apr.2015): |
| linearizeMlist <- |
| ## Undo the recursive nature of the methods list, making a list of |
| ## function definitions, with the names of the list being the |
| ## corresponding signatures (designed for printing; for looping over |
| ## the methods, use `listFromMlist' instead). |
| ## |
| ## The function calls itself recursively. `prev' is the previously |
| ## selected class names. |
| ## |
| ## If argument `classes' is provided, only signatures containing one |
| ## of these classes will be included. |
| function(mlist, inherited = TRUE) { |
| methods <- mlist@methods |
| allMethods <- mlist@allMethods |
| if(inherited && length(allMethods) >= length(methods)) { |
| ## anames <- names(allMethods) |
| ## inh <- is.na(match(anames, names(methods))) |
| methods <- allMethods |
| } |
| preC <- function(y, x)c(x,y) # used with lapply below |
| cnames <- names(methods) |
| value <- list() |
| classes <- list() |
| arguments <- list() |
| argname <- as.character(mlist@argument) |
| for(i in seq_along(cnames)) { |
| mi <- methods[[i]] |
| if(is.function(mi)) { |
| value <- c(value, list(mi)) |
| classes <- c(classes, list(cnames[[i]])) |
| arguments <- c(arguments, list(argname)) |
| } |
| else if(is(mi, "MethodsList")) { |
| .MlistDeprecated() |
| mi <- Recall(mi, inherited) |
| value <- c(value, mi@methods) |
| classes <- c(classes, lapply(mi@classes, preC, cnames[[i]])) |
| arguments <- c(arguments, lapply(mi@arguments, preC, argname)) |
| } |
| else |
| warning(gettextf("skipping methods list element %s of unexpected class %s\n\n", |
| paste(cnames[i], collapse = ", "), |
| dQuote(.class1(mi))), |
| domain = NA) |
| } |
| new("LinearMethodsList", methods = value, classes = classes, arguments = arguments) |
| } |
| |
| print.MethodsList <- function(x, ...) |
| showMlist(x) |
| |
| |
| ## In R's own code, this is *only* used in mergeMethods(), deprecated in R 3.2.0 (Apr.2015) |
| listFromMlist <- |
| ## linearizes the MethodsList object into list(sigs, methods); `prefix' is the partial |
| ## signature (a named list of classes) to be prepended to the signatures in this object. |
| ## |
| ## A utility function used to iterate over all the individual methods in the object. |
| function(mlist, prefix = list(), sigs. = TRUE, methods. = TRUE) |
| { |
| methodSlot <- slot(mlist, "methods") |
| mnames <- names(methodSlot) |
| argName <- as.character(slot(mlist, "argument")) |
| sigs <- list() |
| methods <- list() |
| for(i in seq_along(methodSlot)) { |
| thisMethod <- methodSlot[i] |
| thisClass <- mnames[[i]] |
| prefix[[argName]] <- thisClass |
| if(is.function(thisMethod)) { |
| if(sigs.) sigs <- c(sigs, list(prefix)) |
| if(methods.) methods <- c(methods, list(thisMethod)) |
| } |
| else { |
| more <- Recall(thisMethod, prefix) |
| if(sigs.) sigs <- c(sigs, more[[1]]) |
| if(methods.) methods <- c(methods, more[[2]]) |
| } |
| } |
| list(sigs, methods) |
| } |
| |
| .insertCachedMethods <- function(mlist, argName, Class, fromClass, def) { |
| if(is(def, "MethodsList")) { |
| .MlistDeprecated() |
| ## insert all the cached methods in def |
| newArg <- c(argName, as.character(def@argument)) |
| newDefs <- def@allMethods |
| newSigs <- as.list(names(newDefs)) |
| for(j in seq_along(newDefs)) |
| mlist <- Recall(mlist, newArg, c(Class, newSigs[[j]]), fromClass, |
| newDefs[[j]]) |
| } |
| else { |
| def <- .addMethodFrom(def, argName[1L], Class[1L], fromClass) |
| mlist <- insertMethod(mlist, Class, argName, def, TRUE) |
| } |
| mlist |
| } |
| |
| .addMethodFrom <- function(def, arg, Class, fromClass) { |
| if(is(def, "MethodDefinition")) { |
| ## eventually, we may enforce method definition objects |
| ## If not, just leave raw functions alone (NextMethod won't work) |
| def@target[[arg]] <- Class |
| def@defined[[arg]] <- fromClass |
| } |
| def |
| } |
| |
| ## Define a trivial version of asMethodDefinition for bootstrapping. |
| ## The real version requires several class definitions as well as |
| ## methods for as<- |
| asMethodDefinition <- function(def, signature = list(.anyClassName), sealed = FALSE, fdef = def) { |
| if(is.primitive(def) || is(def, "MethodDefinition")) |
| def |
| else { |
| value = new("MethodDefinition") |
| value@.Data <- def |
| classes <- .MakeSignature(new("signature"), def, signature, fdef) |
| value@target <- classes |
| value@defined <- classes |
| value |
| } |
| } |
| |
| .trimMlist <- function(mlist, fromClass) { |
| mlist@methods <- mlist@methods[fromClass] |
| mlist@allMethods <- mlist@allMethods[fromClass] |
| mlist |
| } |
| |
| .noMlistsFlag <- TRUE |
| .noMlists <- function() { |
| ## if this were to be dynamically variable, but |
| ## it can't, IMO |
| ## isTRUE(getOption("noMlists")) |
| ## so instead |
| .noMlistsFlag |
| } |
| |
| .MlistDepTable <- new.env() |
| .MlistDeprecated <- function(this = "<default>", instead) { |
| if(is.character(this)) { |
| if(exists(this, envir = .MlistDepTable, inherits = FALSE)) |
| return() # have already warned about it |
| else |
| assign(this, TRUE, envir = .MlistDepTable) |
| } |
| base::.Deprecated(msg = paste0( |
| if(missing(this)) |
| "Use of the \"MethodsList\" meta data objects is deprecated." |
| else if(is.character(this)) |
| gettextf( |
| "%s, along with other use of the \"MethodsList\" metadata objects, is deprecated.", |
| dQuote(this)) |
| else |
| gettextf("In %s: use of \"MethodsList\" metadata objects is deprecated.", |
| deparse(this)) |
| , "\n " |
| , if(!missing(instead)) gettextf("Use %s instead. ", dQuote(instead)) |
| , "See ?MethodsList. (This warning is shown once per session.)")) |
| } |
| |
| .MlistDefunct <- function(this = "<default>", instead) { |
| base::.Defunct(msg = paste0( |
| if(missing(this)) |
| "Use of the \"MethodsList\" meta data objects is defunct." |
| else if(is.character(this)) |
| gettextf("%s, along with other use of the \"MethodsList\" metadata objects, is defunct.", |
| dQuote(this)) |
| else |
| gettextf("In %s: use of \"MethodsList\" metadata objects is defunct.", |
| deparse(this)) |
| , " " |
| , if(!missing(instead)) gettextf("Use %s instead. ", dQuote(instead)) |
| , "See ?MethodsList.")) |
| } |
