1# File src/library/methods/R/MethodsList.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2018 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19MethodsList <- 20 ## Create a MethodsList object out of the arguments. 21 ## 22 ## Conceptually, this object is a named collection of methods to be 23 ## dispatched when the (first) argument in a function call matches the 24 ## class corresponding to one of the names. A final, unnamed element 25 ## (i.e., with name `""') corresponds to the default method. 26 ## 27 ## The elements can be either a function, or another MethodsList. In 28 ## the second case, this list implies dispatching on the second 29 ## argument to the function using that list, given a selection of this 30 ## element on the first argument. Thus, method dispatching on an 31 ## arbitrary number of arguments is defined. 32 ## 33 ## MethodsList objects are used primarily to dispatch OOP-style 34 ## methods and, in R, to emulate S4-style methods. 35 function(.ArgName, ...) 36{ 37 .MlistDeprecated("MethodsList()") 38 value <- makeMethodsList(list(...)) 39 if(is.name(.ArgName)){} 40 else if(is.character(.ArgName) && length(.ArgName) == 1) 41 .ArgName <- as.name(.ArgName) 42 else stop("invalid first argument: should be the name of the first argument in the dispatch") 43 slot(value, "argument") <- .ArgName 44 value 45} 46 47makeMethodsList <- function(object, level=1) 48{ 49 .MlistDeprecated("makeMethodsList()") 50 mnames <- allNames(object) 51 if(.noMlists()) { 52 keep <- mnames %in% c("", "ANY") 53 mnames <- mnames[keep] 54 object <- object[keep] 55 } 56 value <- new("MethodsList") 57 i <- match("", mnames) 58 if(!is.na(i)) { 59 ## convert to ANY 60 mnames[[i]] <- "ANY" 61 names(object) <- mnames 62 } 63 if(anyDuplicated(mnames)) 64 stop(gettextf("duplicate element names in 'MethodsList' at level %d: %s", 65 level, paste("\"", unique(mnames[duplicated(mnames)]), "\"", 66 collapse=", ")), domain = NA) 67 for(i in seq_along(object)) { 68 eli <- object[[i]] 69 if(is.function(eli) 70 || is(eli, "MethodsList")) {} 71 else if(is(eli, "list") || 72 is(eli, "named")) 73 object[[i]] <- Recall(eli, NULL, level+1) 74 else 75 stop(gettextf("element %d at level %d (class %s) cannot be interpreted as a function or named list", 76 i, level, dQuote(class(eli))), 77 domain = NA) 78 } 79 slot(value, "methods") <- object 80 value 81} 82 83SignatureMethod <- 84 ## construct a MethodsList object containing (only) this method, corresponding 85 ## to the signature; i.e., such that signature[[1L]] is the match for the first 86 ## argument, signature[[2L]] for the second argument, and so on. The string 87 ## "missing" means a match for a missing argument, and "ANY" means use this as the 88 ## default setting at this level. 89 ## 90 ## The first argument is the argument names to be used for dispatch corresponding to 91 ## the signatures. 92 function(names, signature, definition) 93{ 94 .MlistDeprecated("SignatureMethod()") 95 n <- length(signature) 96 if(n > length(names)) 97 stop("arguments 'names' and 'signature' must have the same length") 98 if(n == 0) 99 return(definition) 100 Class <- signature[[n]] 101 name <- names[[n]] 102 m <- MethodsList(name) 103 slot(m, "methods")[[Class]] <- definition 104 slot(m, "argument") <- as.name(name) 105 SignatureMethod(names[-n], signature[-n], m) 106} 107 108 109insertMethod <- 110 ## insert the definition `def' into the MethodsList object, `mlist', corresponding to 111 ## the signature, and return the modified MethodsList. 112 function(mlist, signature, args, def, cacheOnly = FALSE) 113{ 114 .MlistDeprecated("insertMethod()") 115 if(.noMlists() && !identical(unique(signature), "ANY")) 116 return(mlist) 117 ## Checks for assertions about valid calls. 118 ## See rev. 1.17 for the code before the assertions added. 119 if(identical(args[1L], "...") && !identical(names(signature), "...")) { 120 if(identical(signature[[1L]], "ANY")) 121 stop(gettextf("inserting method with invalid signature matching argument '...' to class %s", 122 dQuote(signature[[1L]])), 123 domain = NA) 124 args <- args[-1L] 125 signature <- signature[-1L] 126 if(length(signature) == 0L) 127 return(mlist) 128 } 129 if(length(signature) == 0L) 130 stop("inserting method corresponding to empty signature") 131 if(!is(mlist, "MethodsList")) 132 stop(gettextf("inserting method into non-methods-list object (class %s)", 133 dQuote(.class1(mlist))), 134 domain = NA) 135 if(length(args) > 1 && !cacheOnly) 136 mlist <- balanceMethodsList(mlist, args) 137 Class <- signature[[1]] 138 methods <- if(cacheOnly) mlist@allMethods else mlist@methods 139 current <- methods[[Class]] 140 if(is(current, "MethodsList")) { 141 nextArg <- as.character(current@argument) 142 sigArgs <- args 143 n <- length(signature) 144 length(sigArgs) <- n 145 if(is.na(match(nextArg, sigArgs))) { 146 n <- match(nextArg, args) - n 147 if(is.na(n)) { ## not in args eitiher 148 n <- 1 149 args <- c(args, nextArg) 150 } 151 ## make explicit the trailing ANY's needed 152 signature <- c(signature, rep("ANY", n)) 153 } 154 } 155 if(length(signature) == 1) { 156 if(is.null(current)) { 157 if(!is.null(def)) 158 methods[[Class]] <- def 159 ## else, no change 160 } 161 else { 162 which <- match(Class, names(methods)) 163 if(is.null(def)) 164 ## delete the method 165 methods <- methods[-which] 166 else 167 methods[[which]] <- def 168 } 169 } 170 else { ## recursively merge, initializing current if necessary 171 if(is.null(current)) 172 current <- new("MethodsList", argument = as.name(args[2L])) 173 else if(is.function(current)) 174 current <- new("MethodsList", argument = as.name(args[2L]), 175 methods = list(ANY = current)) 176 methods[[Class]] <- 177 Recall(current, signature[-1L], args[-1L], def, cacheOnly) 178 } 179 mlist@allMethods <- methods 180 if(!cacheOnly) 181 mlist@methods <- methods 182 mlist 183} 184 185 186MethodsListSelect <- 187 ## select the element of a MethodsList object corresponding to the 188 ## actual arguments (as defined in the suppled environment), 189 ## and return the object, extended to include that method if necessary. 190 ## 191 ## Works recursively. At each level finds an argument name from the current `mlist' 192 ## object, and evaluates this argument (if it is not missing), then uses the 193 ## class of the result to select an element of `mlist'. If such an element 194 ## exists and is another `MethodsList' object, `MethodsListSelect' calls itself recursively 195 ## to resolve using further arguments. Matching includes using a default selection or 196 ## a method specifically linked to class `"missing"'. Once a function is found, it 197 ## is returned as the value. If matching fails, NULL is returned. 198 function(f, env, 199 mlist = NULL, 200 fEnv = if(is(fdef, "genericFunction")) environment(fdef) else baseenv(), 201 finalDefault = finalDefaultMethod(mlist), 202 evalArgs = TRUE, 203 useInherited = TRUE, ## supplied when evalArgs is FALSE 204 fdef = getGeneric(f, where = env), # MUST BE SAFE FROM RECUSIVE METHOD SELECTION 205 resetAllowed = TRUE # FALSE when called from selectMethod, .findNextMethod 206 ) 207{ 208 .MlistDeprecated("MethodsListSelect()") 209 if(!resetAllowed) # ensure we restore the real methods for this function 210 resetMlist <- .getMethodsForDispatch(fdef) 211 ## look for call from C dispatch code during another call to MethodsListSelect 212 if(is.null(f)) {} # Recall, not from C 213 else { 214 fMethods <- .getMethodsForDispatch(fdef) 215 if(is.null(mlist) || (evalArgs && is.function(fMethods))) 216 mlist <- fMethods 217 } 218 resetNeeded <- .setIfBase(f, fdef, mlist) # quickly protect against recursion -- see Methods.R 219 if(resetNeeded) { 220 on.exit(.setMethodsForDispatch(f, fdef, mlist)) 221 } 222 if(!is(mlist, "MethodsList")) { 223 if(is.function(mlist)) # call to f, inside MethodsListSelect 224 {on.exit(); return(mlist)} 225 if(is.null(f)) # recursive recall of MethodsListSelect 226 stop("invalid method sublist") 227 else if(!is.null(mlist)) # NULL => 1st call to genericFunction 228 stop(gettextf("%f is not a valid generic function: methods list was an object of class %s", 229 sQuote(f), dQuote(class(mlist))), 230 domain = NA) 231 } 232 if(!is.logical(useInherited)) 233 stop(gettextf("%s must be TRUE, FALSE, or a named logical vector of those values; got an object of class %s", 234 sQuote("useInherited"), 235 dQuote(class(useInherited))), 236 domain = NA) 237 if(identical(mlist, .getMethodsForDispatch(fdef))) { 238 resetNeeded <- TRUE 239 ## On the initial call: 240 ## turn off any further method dispatch on this function, to avoid recursive 241 ## loops if f is a function used in MethodsListSelect. 242 ## TODO: Using namespaces in the methods package would eliminate the need for this 243 .setMethodsForDispatch(f, fdef, finalDefault) 244 if(is(mlist, "MethodsList")) { 245 on.exit(.setMethodsForDispatch(f, fdef, mlist)) 246 } 247 } 248 argName <- slot(mlist, "argument") 249 arg <- NULL ## => don't use instance-specific inheritance 250 if(evalArgs) { 251 ## check for missing argument. NB: S sense, not that of R base missing() 252 if(missingArg(argName, env, TRUE)) 253 thisClass <- "missing" 254 else { 255 arg <- eval(as.name(argName), env) ## DO use instance-specific inheritance 256 if(missing(arg)) ## S3 weird R code? Bail out! 257 return(finalDefault) 258 thisClass <- .class1(arg) 259 } 260 } 261 else 262 thisClass <- get(as.character(argName), envir = env, inherits = FALSE) 263 if(isTRUE(useInherited) || isFALSE(useInherited)) 264 thisInherit <- nextUseInherited <- useInherited 265 else { 266 which <- match(as.character(argName), names(useInherited)) 267 if(is.na(which)) { 268 nextUseInherited <- useInherited 269 thisInherit <- TRUE 270 } 271 else { 272 thisInherit <- useInherited[[which]] 273 nextUseInherited <- useInherited[-which] 274 } 275 } 276 fromClass <- thisClass ## will mark the class actually providing the method 277 allMethods <- mlist@allMethods 278 which <- match(thisClass, names(allMethods)) 279 inherited <- is.na(which) 280 selection <- if(inherited) NULL else allMethods[[which]] 281 if(!inherited) { 282 if(is.function(selection)) { 283 if(is.null(f)) { 284 ## An inherited method at the next level up. 285 ## only the inherited method should be added 286 mlist <- .trimMlist(mlist, fromClass) 287 } 288 value <- mlist ## no change 289 } 290 else { 291 ## recursive call with NULL function name, to allow search to fail & 292 ## to suppress any reset actions. 293 method <- Recall(NULL, env, selection, finalDefault = finalDefault, 294 evalArgs = evalArgs, useInherited = nextUseInherited, fdef = fdef, 295 ) 296 if(is(method, "EmptyMethodsList")) 297 value <- method 298 else { 299 mlist@allMethods[[which]] <- method 300 value <- mlist 301 } 302 } 303 } 304 if(inherited || is(value, "EmptyMethodsList")) { 305 ## direct selection failed at this level or below 306 method <- NULL 307 if(thisInherit) { 308 allSelections <- inheritedSubMethodLists(arg, fromClass, mlist, env) 309 allClasses <- names(allSelections) 310 for(i in seq_along(allSelections)) { 311 selection <- allSelections[[i]] 312 fromClass <- allClasses[[i]] 313 if(is.function(selection)) 314 method <- selection 315 else if(is(selection, "MethodsList")) { 316 ## go on to try matching further arguments 317 method <- Recall(NULL, env, selection, finalDefault = finalDefault, 318 evalArgs = evalArgs, 319 useInherited = nextUseInherited, fdef = fdef) 320 if(is(method, "EmptyMethodsList")) 321 selection <- method ## recursive selection failed 322 } 323 if(!is(selection, "EmptyMethodsList")) 324 break 325 } 326 } 327 if((is.null(selection) || is(selection, "EmptyMethodsList")) 328 && !is.null(f) && !is.null(finalDefault)) { 329 ## only use the final default method after exhausting all 330 ## other possibilities, at all levels. 331 method <- finalDefault 332 fromClass <- "ANY" 333 } 334 if(is.null(method) || is(method, "EmptyMethodsList")) 335 value <- emptyMethodsList(mlist, thisClass) ## nothing found 336 else { 337 method <- MethodAddCoerce(method, argName, thisClass, fromClass) 338 value <- .insertCachedMethods(mlist, as.character(argName), thisClass, fromClass, 339 method) 340 } 341 } 342 if(!is.null(f)) { 343 ## top level 344 if(is(value, "EmptyMethodsList")) ## selection failed 345 value <- NULL 346 if(resetNeeded) { 347 on.exit() # cancel the restore of the original mlist 348 if(resetAllowed) { 349 if(is.null(value)) resetMlist <- mlist else resetMlist <- value 350 } 351 .setMethodsForDispatch(f, fdef, resetMlist) 352 if(dispatchIsInternal(fdef)) 353 setPrimitiveMethods(f, finalDefault, "set", fdef, resetMlist) 354 } 355 356 } 357 value 358} 359 360emptyMethodsList <- function(mlist, thisClass = "ANY", sublist = list()) { 361 .MlistDeprecated("emptyMethodsList()") 362 sublist[thisClass] <- list(NULL) 363 new("EmptyMethodsList", argument = mlist@argument, sublist = sublist) 364} 365 366insertMethodInEmptyList <- function(mlist, def) { 367 .MlistDeprecated("insertMethodInEmptyList()") 368 value <- new("MethodsList", argument = mlist@argument) 369 sublist <- mlist@sublist 370 submethods <- sublist[[1L]] 371 if(is.null(submethods)) 372 sublist[[1L]] <- def 373 else 374 sublist[[1L]] <- Recall(submethods, def) 375 value@allMethods <- sublist 376 value 377} 378 379 380 381 382finalDefaultMethod <- 383 ## Return the default method from the generic (it may be NULL, a method object or a primitive. 384 ## this previously searched in a MethodsList object. Once those are gone, the loop should 385 ## be irrelevant except as an error check. 386 function(method) 387{ 388 repeat { 389 if(is.function(method) # <- somewhat liberal, but catches both methods and primitives 390 || is.null(method)) 391 break 392 if(is(method, "MethodsList")) { 393 .MlistDeprecated() 394 method <- slot(method, "methods")[["ANY"]] 395 } else 396 stop(gettextf( 397 "default method must be a method definition, a primitive or NULL: got an object of class %s", 398 dQuote(class(method))), 399 domain = NA) 400 } 401 method 402} 403 404 405inheritedSubMethodLists <- 406 ## Utility function to match the object to the elements of a methods list. 407 ## 408 ## The function looks only for an inherited match, and only among 409 ## the methods that are not themselves inherited. (Inherited methods when found are 410 ## stored in the session copy of the methods list, but they themselves should not be 411 ## used for finding inherited matches, because an erroneous match could be found depending 412 ## on which methods were previously used. See the detailed discussion of methods.) 413 function(object, thisClass, mlist, ev) 414{ 415 .MlistDeprecated("inheritedSubMethodLists()") 416 methods <- slot(mlist, "methods")## only direct methods 417 defaultMethod <- methods[["ANY"]]## maybe NULL 418 classes <- names(methods) 419 value <- list() 420 if(.identC(thisClass, "missing")) { 421 ## no superclasses for "missing" 422 } 423 else { 424 ## search in the superclasses, but don't use inherited methods 425 ## There are two cases: if thisClass is formally defined & unsealed, use its 426 ## superclasses. Otherwise, look in the subclasses of those classes for 427 ## which methods exist. 428 classDef <- getClassDef(thisClass, ev) 429 useSuperClasses <- !is.null(classDef) && !classDef@sealed 430 if(useSuperClasses) { 431 ## for consistency, order the available methods by 432 ## the ordering of the superclasses of thisClass 433 superClasses <- names(classDef@contains) 434 classes <- superClasses[!is.na(match(superClasses, classes))] 435 for(which in seq_along(classes)) { 436 tryClass <- classes[[which]] 437 ## TODO: There is potential bug here: If the is relation is conditional, 438 ## we should not cache this selection. Needs another trick in the environment 439 ## to FORCE no caching regardless of what happens elsewhere; e.g., storing a 440 ## special object in .Class 441 if(is.null(object) || is(object, tryClass)) { 442 value[[tryClass]] <- methods[[tryClass]] 443 } 444 } 445 } 446 else { 447 for(which in seq_along(classes)) { 448 tryClass <- classes[[which]] 449 tryClassDef <- getClassDef(tryClass, ev) 450 if(!is.null(tryClassDef) && 451 !is.na(match(thisClass, names(tryClassDef@subclasses)))) 452 value[[tryClass]] <- methods[[which]] 453 } 454 } 455 } 456 if(!is.null(defaultMethod)) 457 value[["ANY"]] <- defaultMethod 458 value 459} 460 461 462matchSignature <- 463 ## Match the signature object (a partially or completely named subset of the 464 ## arguments of `fun', and return a vector of all the classes in the order specified 465 ## by the signature slot of the generic. The classes not specified by `signature 466 ##' will be `"ANY"' in the value. 467 function(signature, fun, where = baseenv()) 468{ 469 if(!is(fun, "genericFunction")) 470 stop(gettextf("trying to match a method signature to an object (of class %s) that is not a generic function", 471 dQuote(class(fun))), 472 domain = NA) 473 anames <- fun@signature 474 if(length(signature) == 0L) 475 return(character()) 476 if(is(signature,"character")) { 477 pkgs <- packageSlot(signature) # includes case of "ObjectsWithPackage" 478 if(is.null(pkgs)) 479 pkgs <- character(length(signature)) 480 else if(length(pkgs) != length(signature)) 481 stop("invalid 'package' slot or attribute, wrong length") 482 sigClasses <- as.character(signature) 483 } 484 else if(is(signature, "list")) { 485 sigClasses <- pkgs <- character(length(signature)) 486 for(i in seq_along(signature)) { 487 cli <- signature[[i]] 488 if(is(cli, "classRepresentation")) { 489 sigClasses[[i]] <- cli@className 490 pkgs[[i]] <- cli@package 491 } 492 else if(is(cli, "character") && length(cli) == 1) { 493 sigClasses[[i]] <- cli 494 pkgi <- packageSlot(cli) 495 if(is.character(pkgi)) 496 pkgs[[i]] <- pkgi 497 } 498 else 499 stop(gettextf("invalid element in a list for \"signature\" argument; element %d is neither a class definition nor a class name", 500 i), domain = NA) 501 } 502 } 503 else 504 stop(gettextf("trying to match a method signature of class %s; expects a list or a character vector", 505 dQuote(class(signature))), 506 domain = NA) 507 if(!identical(where, baseenv())) { 508 ## fill in package information, warn about undefined classes 509 unknown <- !nzchar(pkgs) 510 for(i in seq_along(sigClasses)[unknown]) { 511 cli <- getClassDef(sigClasses[[i]], where) 512 if(!is.null(cli)) { 513 pkgs[[i]] <- cli@package 514 unknown[[i]] <- FALSE 515 } 516 } 517 if(any(unknown)) { 518 unknown <- unique(sigClasses[unknown]) 519 ## coerce(), i.e., setAs() may use *one* unknown class 520 MSG <- if(identical(as.vector(coerce@generic), "coerce") && 521 length(unknown) == 1) message 522 else function(...) warning(..., call. = FALSE) 523 MSG(.renderSignature(fun@generic, signature), 524 sprintf(ngettext(length(unknown), 525 "no definition for class %s", 526 "no definition for classes %s"), 527 paste(dQuote(unknown), collapse = ", ")), 528 domain = NA) 529 } 530 } 531 signature <- as.list(signature) 532 if(length(sigClasses) != length(signature)) 533 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", 534 sQuote(fun@generic), 535 length(sigClasses), 536 length(signature)), 537 domain = NA) 538 if(length(signature) > length(anames)) 539 stop(gettextf("more elements in the method signature (%d) than in the generic signature (%d) for function %s", 540 length(signature), length(anames), sQuote(fun@generic)), domain = NA) 541 if(is.null(names(signature))) { 542 which <- seq_along(signature) 543 } 544 else { 545 ## construct a function call with the same naming pattern & 546 ## values as signature 547 sigList <- signature 548 for(i in seq_along(sigList)) 549 sigList[[i]] <- c(sigClasses[[i]], pkgs[[i]]) 550 fcall <- do.call("call", c("fun", sigList)) 551 argmatches <- charmatch(names(sigList), anames) 552 if (anyNA(argmatches)) 553 stop(gettextf("there are named arguments (%s) in the method signature that are missing from the generic signature, for function %s", 554 paste(sQuote(names(sigList)[is.na(argmatches)]), 555 collapse = ", "), 556 sQuote(fun@generic), domain = NA)) 557 ambig <- argmatches == 0L & names(sigList) != "" 558 if (any(ambig)) 559 stop(gettextf("there are named arguments (%s) in the method signature that ambiguously match the generic signature, for function %s", 560 paste(sQuote(names(sigList)[ambig]), 561 collapse = ", "), 562 sQuote(fun@generic), domain = NA)) 563 ## match the call to the formal signature (usually the formal args) 564 if(identical(anames, formalArgs(fun))) 565 smatch <- match.call(fun, fcall) 566 else { 567 fmatch <- fun 568 ff <- as.list(anames); names(ff) <- anames 569 formals(fmatch, envir = environment(fun)) <- ff 570 smatch <- match.call(fmatch, fcall) 571 } 572 snames <- names(smatch)[-1L] 573 which <- match(snames, anames) 574 ## Assertion: match.call has permuted the args into the order of formal args, 575 ## and carried along the values. Get the supplied classes in that 576 ## order, from the matched args in the call object. 577 if(anyNA(which)) 578 stop(sprintf(ngettext(sum(is.na(which)), 579 "in the method signature for function %s invalid argument name in the signature: %s", 580 "in the method signature for function %s invalid argument names in the signature: %s"), 581 sQuote(fun@generic), 582 paste(snames[is.na(which)], collapse = ", ")), 583 domain = NA) 584 smatch <- smatch[-1] 585 for(i in seq_along(smatch)) { 586 eli <- smatch[[i]] 587 sigClasses[[i]] <- eli[[1]] 588 pkgs[[i]] <- eli[[2]] 589 } 590 } 591 n <- length(anames) 592 value <- rep("ANY", n) 593 valueP <- rep("methods", n) 594 names(value) <- anames 595 value[which] <- sigClasses 596 valueP[which] <- pkgs 597 unspec <- value == "ANY" 598 ## remove the trailing unspecified classes 599 while(n > 1 && unspec[[n]]) 600 n <- n-1 601 length(value) <- length(valueP) <- n 602 attr(value, "package") <- valueP 603 ## <FIXME> Is there a reason (bootstrapping?) why this 604 ## is not an actual object from class "signature"? 605 ## See .MakeSignature() </FIXME> 606 value 607} 608 609showMlist <- 610 ## Prints the contents of the MethodsList. If `includeDefs' the signatures and the 611 ## corresponding definitions will be printed; otherwise, only the signatures. 612 ## 613 ## If `includeDefs' is `TRUE', the currently known inherited methods are included; 614 ## otherwise, only the directly defined methods. 615function(mlist, includeDefs = TRUE, inherited = TRUE, classes = NULL, useArgNames = TRUE, 616 printTo = stdout()) 617{ 618 .MlistDeprecated("showMlist()") 619 if(isFALSE(printTo)) { 620 tmp <- tempfile() 621 con <- file(tmp, "w") 622 } 623 else 624 con <- printTo 625 object <- linearizeMlist(mlist, inherited) 626 methods <- object@methods 627 signatures <- object@classes 628 args <- object@arguments 629 if(!is.null(classes) && length(signatures)>0) { 630 keep <- !vapply(signatures, function(x, y) all(is.na(match(x, y))), NA, classes) 631 methods <- methods[keep] 632 signatures <- signatures[keep] 633 args <- args[keep] 634 } 635 if(length(methods) == 0) 636 cat(file=con, "<Empty Methods List>\n") 637 else { 638 n <- length(methods) 639 labels <- character(n) 640 if(useArgNames) { 641 for(i in 1L:n) { 642 sigi <- signatures[[i]] 643 labels[[i]] <- paste0(args[[i]], " = \"", sigi, "\"", 644 collapse = ", ") 645 } 646 } 647 else { 648 for(i in 1L:n) 649 labels[[i]] <- paste(signatures[[i]], collapse = ", ") 650 } 651 for(i in seq_along(methods)) { 652 cat(file=con, (if(includeDefs) "## Signature:" else ""), labels[[i]]) 653 method <- methods[[i]] 654 if(includeDefs) { 655 cat(file=con, ":\n") 656 if(is(method, "MethodDefinition")) ## really an assertion 657 cat(file=con, deparse(method@.Data), sep="\n") 658 else 659 cat(file=con, deparse(method), sep="\n") 660 } 661 if(is(method, "MethodDefinition") && 662 !identical(method@target, method@defined)) { 663 defFrom <- method@defined 664 cat(file = con, if(includeDefs) "##:" else "\n", 665 " (inherited from ", 666 paste0(names(defFrom), " = \"", 667 as.character(defFrom), "\"", 668 collapse = ", "), 669 ")", if(includeDefs) "\n", sep="") 670 } 671 cat(file=con, "\n") 672 } 673 } 674 if(isFALSE(printTo)) { 675 close(con) 676 value <- readLines(tmp) 677 unlink(tmp) 678 value 679 } 680} 681 682promptMethods <- function(f, filename = NULL, methods) 683{ 684 ## Generate information in the style of 'prompt' for the methods of 685 ## the generic named 'f'. 686 ## 687 ## 'filename' can be a logical or NA or the name of a file to print 688 ## to. If it 'FALSE', the methods skeleton is returned, to be 689 ## included in other printing (typically, the output from 'prompt'). 690 691 escape <- function(txt) gsub("%", "\\%", txt, fixed=TRUE) 692 packageString <- "" 693 694 fdef <- getGeneric(f) 695 if(!isGeneric(f, fdef=fdef)) 696 stop(gettextf("no generic function found corresponding to %s", 697 sQuote(f)), 698 domain = NA) 699 if(missing(methods)) { 700 methods <- findMethods(fdef) 701 ## try making packageString 702 where <- .genEnv(fdef, topenv(parent.frame())) 703 if(!identical(where, .GlobalEnv)) 704 packageString <- 705 sprintf("in Package \\pkg{%s}", getPackageName(where)) 706 } 707 fullName <- utils:::topicName("methods", f) 708 n <- length(methods) 709 labels <- character(n) 710 aliases <- character(n) 711 signatures <- findMethodSignatures(methods = methods, target=TRUE) 712 args <- colnames(signatures) # the *same* for all 713 for(i in seq_len(n)) { 714 sigi <- signatures[i, ] 715 labels[[i]] <- 716 sprintf("\\code{signature(%s)}", 717 paste(sprintf("%s = \"%s\"", args, escape(sigi)), 718 collapse = ", ")) 719 aliases[[i]] <- 720 paste0("\\alias{", 721 utils:::topicName("method", c(f, signatures[i,])), 722 "}") 723 } 724 text <- paste0("\n\\item{", labels, 725 "}{\n%% ~~describe this method here~~\n}") 726 text <- c("\\section{Methods}{\n\\describe{", text, "}}") 727 aliasText <- c(paste0("\\alias{", escape(fullName), "}"), escape(aliases)) 728 if(isFALSE(filename)) 729 return(c(aliasText, text)) 730 731 if(is.null(filename) || isTRUE(filename)) 732 filename <- paste0(fullName, ".Rd") 733 734 Rdtxt <- 735 list(name = paste0("\\name{", fullName, "}"), 736 type = "\\docType{methods}", 737 aliases = aliasText, 738 ## <FIXME> 739 ## Title and description are ok as auto-generated: should 740 ## they be flagged as such (via '~~' which are quite often 741 ## left in by authors)? 742 title = 743 sprintf("\\title{ ~~ Methods for Function \\code{%s} %s ~~}", 744 f, packageString), 745 description = 746 paste0("\\description{\n ~~ Methods for function", 747 " \\code{", f, "} ", 748 sub("^in Package", "in package", packageString), 749 " ~~\n}"), 750 ## </FIXME> 751 "section{Methods}" = text, 752 keywords = c("\\keyword{methods}", 753 "\\keyword{ ~~ other possible keyword(s) ~~ }")) 754 755 if(is.na(filename)) return(Rdtxt) 756 757 cat(unlist(Rdtxt), file = filename, sep = "\n") 758 .message("A shell of methods documentation has been written", 759 .fileDesc(filename), ".\n") 760 invisible(filename) 761} 762 763##' only called from showMlist() above, which has been deprecated in R 3.2.0 (Apr.2015): 764linearizeMlist <- 765 ## Undo the recursive nature of the methods list, making a list of 766 ## function definitions, with the names of the list being the 767 ## corresponding signatures (designed for printing; for looping over 768 ## the methods, use `listFromMlist' instead). 769 ## 770 ## The function calls itself recursively. `prev' is the previously 771 ## selected class names. 772 ## 773 ## If argument `classes' is provided, only signatures containing one 774 ## of these classes will be included. 775 function(mlist, inherited = TRUE) { 776 methods <- mlist@methods 777 allMethods <- mlist@allMethods 778 if(inherited && length(allMethods) >= length(methods)) { 779## anames <- names(allMethods) 780## inh <- is.na(match(anames, names(methods))) 781 methods <- allMethods 782 } 783 preC <- function(y, x)c(x,y) # used with lapply below 784 cnames <- names(methods) 785 value <- list() 786 classes <- list() 787 arguments <- list() 788 argname <- as.character(mlist@argument) 789 for(i in seq_along(cnames)) { 790 mi <- methods[[i]] 791 if(is.function(mi)) { 792 value <- c(value, list(mi)) 793 classes <- c(classes, list(cnames[[i]])) 794 arguments <- c(arguments, list(argname)) 795 } 796 else if(is(mi, "MethodsList")) { 797 .MlistDeprecated() 798 mi <- Recall(mi, inherited) 799 value <- c(value, mi@methods) 800 classes <- c(classes, lapply(mi@classes, preC, cnames[[i]])) 801 arguments <- c(arguments, lapply(mi@arguments, preC, argname)) 802 } 803 else 804 warning(gettextf("skipping methods list element %s of unexpected class %s\n\n", 805 paste(cnames[i], collapse = ", "), 806 dQuote(.class1(mi))), 807 domain = NA) 808 } 809 new("LinearMethodsList", methods = value, classes = classes, arguments = arguments) 810 } 811 812print.MethodsList <- function(x, ...) 813 showMlist(x) 814 815 816## In R's own code, this is *only* used in mergeMethods(), deprecated in R 3.2.0 (Apr.2015) 817listFromMlist <- 818 ## linearizes the MethodsList object into list(sigs, methods); `prefix' is the partial 819 ## signature (a named list of classes) to be prepended to the signatures in this object. 820 ## 821 ## A utility function used to iterate over all the individual methods in the object. 822 function(mlist, prefix = list(), sigs. = TRUE, methods. = TRUE) 823{ 824 methodSlot <- slot(mlist, "methods") 825 mnames <- names(methodSlot) 826 argName <- as.character(slot(mlist, "argument")) 827 sigs <- list() 828 methods <- list() 829 for(i in seq_along(methodSlot)) { 830 thisMethod <- methodSlot[i] 831 thisClass <- mnames[[i]] 832 prefix[[argName]] <- thisClass 833 if(is.function(thisMethod)) { 834 if(sigs.) sigs <- c(sigs, list(prefix)) 835 if(methods.) methods <- c(methods, list(thisMethod)) 836 } 837 else { 838 more <- Recall(thisMethod, prefix) 839 if(sigs.) sigs <- c(sigs, more[[1]]) 840 if(methods.) methods <- c(methods, more[[2]]) 841 } 842 } 843 list(sigs, methods) 844} 845 846.insertCachedMethods <- function(mlist, argName, Class, fromClass, def) { 847 if(is(def, "MethodsList")) { 848 .MlistDeprecated() 849 ## insert all the cached methods in def 850 newArg <- c(argName, as.character(def@argument)) 851 newDefs <- def@allMethods 852 newSigs <- as.list(names(newDefs)) 853 for(j in seq_along(newDefs)) 854 mlist <- Recall(mlist, newArg, c(Class, newSigs[[j]]), fromClass, 855 newDefs[[j]]) 856 } 857 else { 858 def <- .addMethodFrom(def, argName[1L], Class[1L], fromClass) 859 mlist <- insertMethod(mlist, Class, argName, def, TRUE) 860 } 861 mlist 862} 863 864.addMethodFrom <- function(def, arg, Class, fromClass) { 865 if(is(def, "MethodDefinition")) { 866 ## eventually, we may enforce method definition objects 867 ## If not, just leave raw functions alone (NextMethod won't work) 868 def@target[[arg]] <- Class 869 def@defined[[arg]] <- fromClass 870 } 871 def 872} 873 874## Define a trivial version of asMethodDefinition for bootstrapping. 875## The real version requires several class definitions as well as 876## methods for as<- 877asMethodDefinition <- function(def, signature = list(.anyClassName), sealed = FALSE, fdef = def) { 878 if(is.primitive(def) || is(def, "MethodDefinition")) 879 def 880 else { 881 value = new("MethodDefinition") 882 value@.Data <- def 883 classes <- .MakeSignature(new("signature"), def, signature, fdef) 884 value@target <- classes 885 value@defined <- classes 886 value 887 } 888 } 889 890.trimMlist <- function(mlist, fromClass) { 891 mlist@methods <- mlist@methods[fromClass] 892 mlist@allMethods <- mlist@allMethods[fromClass] 893 mlist 894} 895 896.noMlistsFlag <- TRUE 897.noMlists <- function() { 898 ## if this were to be dynamically variable, but 899 ## it can't, IMO 900 ## isTRUE(getOption("noMlists")) 901 ## so instead 902 .noMlistsFlag 903} 904 905.MlistDepTable <- new.env() 906.MlistDeprecated <- function(this = "<default>", instead) { 907 if(is.character(this)) { 908 if(exists(this, envir = .MlistDepTable, inherits = FALSE)) 909 return() # have already warned about it 910 else 911 assign(this, TRUE, envir = .MlistDepTable) 912 } 913 base::.Deprecated(msg = paste0( 914 if(missing(this)) 915 "Use of the \"MethodsList\" meta data objects is deprecated." 916 else if(is.character(this)) 917 gettextf( 918 "%s, along with other use of the \"MethodsList\" metadata objects, is deprecated.", 919 dQuote(this)) 920 else 921 gettextf("In %s: use of \"MethodsList\" metadata objects is deprecated.", 922 deparse(this)) 923 , "\n " 924 , if(!missing(instead)) gettextf("Use %s instead. ", dQuote(instead)) 925 , "See ?MethodsList. (This warning is shown once per session.)")) 926} 927 928.MlistDefunct <- function(this = "<default>", instead) { 929 base::.Defunct(msg = paste0( 930 if(missing(this)) 931 "Use of the \"MethodsList\" meta data objects is defunct." 932 else if(is.character(this)) 933 gettextf("%s, along with other use of the \"MethodsList\" metadata objects, is defunct.", 934 dQuote(this)) 935 else 936 gettextf("In %s: use of \"MethodsList\" metadata objects is defunct.", 937 deparse(this)) 938 , " " 939 , if(!missing(instead)) gettextf("Use %s instead. ", dQuote(instead)) 940 , "See ?MethodsList.")) 941} 942