1# File src/library/utils/R/objects.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2020 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 19## findGeneric(fname) : is 'fname' the name of an S3 generic ? 20## [unexported function used only in this file] 21findGeneric <- function(fname, envir, warnS4only = TRUE) 22{ 23 if(!exists(fname, mode = "function", envir = envir)) return("") 24 f <- get(fname, mode = "function", envir = envir) 25 ## FIXME? In the first case, e.g. 'methods(qr)', we are very inefficient: 26 ## inside methods() we transform the 'qr' function object into a character, 27 ## whereas here, we revert this, searching around unnecessarily 28 ## 29 if(.isMethodsDispatchOn() && methods::is(f, "genericFunction")) { 30 ## maybe an S3 generic was turned into the S4 default 31 ## Try to find it, otherwise warn : 32 fMethsEnv <- methods::getMethodsForDispatch(f) 33 meths <- as.list(fMethsEnv, all.names=TRUE) 34 r <- meths[grep("^ANY\\b", names(meths))] 35 if(any(ddm <- vapply(r, methods::is, logical(1L), "derivedDefaultMethod"))) 36 f <- r[ddm][[1]]@.Data 37 else if(warnS4only) 38 warning(gettextf( 39 "'%s' is a formal generic function; S3 methods will not likely be found", 40 fname), domain = NA) 41 } 42 isUMEbrace <- function(e) { 43 for (ee in as.list(e[-1L])) 44 if (nzchar(res <- isUME(ee))) return(res) 45 "" 46 } 47 isUMEif <- function(e) { 48 if (length(e) == 3L) isUME(e[[3L]]) 49 else { 50 if (nzchar(res <- isUME(e[[3L]]))) res 51 else if (nzchar(res <- isUME(e[[4L]]))) res 52 else "" 53 } 54 } 55 isUME <- function(e) { ## is it an "UseMethod() calling function" ? 56 if (is.call(e) && (is.name(e[[1L]]) || is.character(e[[1L]]))) { 57 switch(as.character(e[[1L]]), 58 UseMethod = as.character(e[[2L]]), 59 "{" = isUMEbrace(e), 60 "if" = isUMEif(e), 61 "") 62 } else "" 63 } 64 isUME(body(f)) 65} 66 67getKnownS3generics <- 68function() 69 c(names(.knownS3Generics), tools:::.get_internal_S3_generics()) 70 71.S3methods <- 72function(generic.function, class, envir=parent.frame()) 73{ 74 rbindSome <- function(df, nms, msg) { 75 ## rbind.data.frame() -- dropping rows with duplicated names 76 nms <- unique(nms) 77 n2 <- length(nms) 78 dnew <- data.frame(visible = rep.int(FALSE, n2), 79 from = rep.int(msg, n2), 80 row.names = nms) 81 n <- nrow(df) 82 if(n == 0L) return(dnew) 83 ## else 84 keep <- !duplicated(c(rownames(df), rownames(dnew))) 85 rbind(df [keep[1L:n] , ], 86 dnew[keep[(n+1L):(n+n2)] , ]) 87 } 88 89 S3MethodsStopList <- tools::nonS3methods(NULL) 90 knownGenerics <- getKnownS3generics() 91 sp <- search() 92 if(nzchar(lookup <- 93 Sys.getenv("_R_S3_METHOD_LOOKUP_BASEENV_AFTER_GLOBALENV_"))) { 94 lookup <- tools:::config_val_to_logical(lookup) 95 if(lookup) sp <- sp[c(1L, length(sp))] 96 } 97 methods.called <- identical(sys.call(-1)[[1]], as.symbol("methods")) 98 an <- lapply(seq_along(sp), ls) 99 lens <- lengths(an) 100 an <- unlist(an, use.names=FALSE) 101 names(an) <- rep.int(sp, lens) 102 an <- an[!duplicated(an)] # removed masked objects, *keep* names 103 info <- data.frame(visible = rep.int(TRUE, length(an)), 104 from = .rmpkg(names(an)), 105 row.names = an) 106 if (!missing(generic.function)) { 107 if (!is.character(generic.function)) 108 generic.function <- deparse1(substitute(generic.function)) 109 ## else 110 if(!exists(generic.function, mode = "function", envir = envir) && 111 !any(generic.function == c("Math", "Ops", "Complex", "Summary"))) 112 stop(gettextf("no function '%s' is visible", generic.function), 113 domain = NA) 114 warn.not.generic <- FALSE 115 if(!any(generic.function == knownGenerics)) { 116 truegf <- findGeneric(generic.function, envir, warnS4only = !methods.called) 117 if(truegf == "") 118 warn.not.generic <- TRUE 119 else if(truegf != generic.function) { 120 warning(gettextf("generic function '%s' dispatches methods for generic '%s'", 121 generic.function, truegf), domain = NA) 122 generic.function <- truegf 123 } 124 } 125 info <- info[startsWith(row.names(info), paste0(generic.function,".")), ] 126 info <- info[! row.names(info) %in% S3MethodsStopList, ] 127 ## check that these are all functions 128 ## might be none at this point 129 if(nrow(info)) { 130 keep <- vapply(row.names(info), exists, logical(1), mode="function") 131 info <- info[keep, ] 132 } 133 if(warn.not.generic && nrow(info)) 134 warning(gettextf( 135 "function '%s' appears not to be S3 generic; found functions that look like S3 methods", 136 generic.function), domain = NA) 137 138 ## also look for registered methods from namespaces 139 ## we assume that only functions get registered. 140 defenv <- if(!is.na(w <- .knownS3Generics[generic.function])) 141 asNamespace(w) 142 else { 143 genfun <- get(generic.function, mode = "function", envir = envir) 144 if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) 145 genfun <- methods::finalDefaultMethod(genfun@default) 146 .defenv_for_S3_registry(genfun) 147 } 148 S3reg <- names(get(".__S3MethodsTable__.", envir = defenv)) 149 S3reg <- S3reg[startsWith(S3reg, paste0(generic.function,"."))] 150 if(length(S3reg)) 151 info <- rbindSome(info, S3reg, msg = 152 paste("registered S3method for", 153 generic.function)) 154 ## both all() and all.equal() are generic, so 155 if(generic.function == "all") 156 info <- info[-grep("^all\\.equal", row.names(info)), ] 157 } 158 else if (!missing(class)) { 159 if (!is.character(class)) 160 class <- deparse1(substitute(class)) 161 if(length(class) > 1L) { 162 warning("'class' is of length > 1; only the first element will be used") 163 class <- class[1L] 164 } 165 name <- paste0(".", class, "$") 166 name <- gsub("([.[])", "\\\\\\1", name) 167 info <- info[grep(name, row.names(info)), ] 168 info <- info[! row.names(info) %in% S3MethodsStopList, ] 169 170 if(nrow(info)) { 171 ## check if we can find a generic matching the name 172 possible.generics <- gsub(name, "", row.names(info)) 173 keep <- vapply(possible.generics, function(nm) { 174 if(nm %in% knownGenerics) return(TRUE) 175 where <- find(nm, mode = "function") 176 if(length(where)) 177 any(vapply(where, function(w) 178 nzchar(findGeneric(nm, envir=as.environment(w))), 179 logical(1))) 180 else FALSE 181 }, logical(1)) 182 info <- info[keep, ] 183 } 184 185 ## also look for registered methods in loaded namespaces. 186 ## These should only be registered in environments containing 187 ## the corresponding generic, so we don't check again. 188 ## Note that the generic will not necessarily be visible, 189 ## as the package may not be loaded. 190 S3reg <- unlist(lapply(loadedNamespaces(), function(i) 191 ls(get(".__S3MethodsTable__.", envir = asNamespace(i)), pattern = name))) 192 ## now methods like print.summary.aov will be picked up, 193 ## so we do look for such mismatches. 194 if(length(S3reg)) 195 S3reg <- S3reg[vapply(gsub(name, "", S3reg), exists, NA)] 196 if(length(S3reg)) 197 info <- rbindSome(info, S3reg, msg = "registered S3method") 198 } 199 else stop("must supply 'generic.function' or 'class'") 200 201 info$generic <- if (!missing(generic.function)) 202 rep.int(generic.function, nrow(info)) 203 else sub(paste0("\\.", class, "$"), "", row.names(info)) 204 info$isS4 <- rep.int(FALSE, nrow(info)) 205 206 info <- info[sort.list(row.names(info)), , drop=FALSE] 207 res <- row.names(info) 208 class(res) <- "MethodsFunction" 209 attr(res, "info") <- info 210 attr(res, "byclass") <- missing(generic.function) 211 res 212} 213 214methods <- 215function(generic.function, class) 216{ 217 envir <- parent.frame() 218 if(!missing(generic.function) && !is.character(generic.function)) { 219 what <- substitute(generic.function) 220 generic.function <- 221 if(is.function(generic.function) && 222 is.call(what) && 223 (deparse(what[[1L]], nlines=1L) %in% c("::", ":::"))) { 224 what <- as.character(what[2:3]) 225 envir <- asNamespace(what[[1L]]) 226 what[[2L]] 227 } else 228 deparse(what) 229 } 230 231 if (!missing(class) && !is.character(class)) 232 class <- deparse1(substitute(class)) 233 234 s3 <- .S3methods(generic.function, class, envir) 235 s4 <- if(.isMethodsDispatchOn()) methods::.S4methods(generic.function, class) 236 237 .MethodsFunction(s3, s4, missing(generic.function)) 238} 239 240.MethodsFunction <- 241function(s3, s4, byclass) 242{ 243 info3 <- attr(s3, "info") 244 info4 <- attr(s4, "info") 245 info <- rbind(info3, info4) 246 dups <- duplicated(c(rownames(info3), rownames(info4))) 247 info <- info[!dups, , drop=FALSE] 248 info <- info[order(rownames(info)), , drop=FALSE] 249 structure(rownames(info), info=info, byclass=byclass, 250 class="MethodsFunction") 251} 252 253format.MethodsFunction <- function(x, byclass = attr(x, "byclass"), ...) 254{ 255 info <- attr(x, "info") 256 if (byclass) 257 unique(info$generic) 258 else 259 paste0(rownames(info), visible = ifelse(info$visible, "", "*")) 260} 261 262print.MethodsFunction <- function(x, byclass = attr(x, "byclass"), ...) 263{ 264 if (length(values <- format(x, byclass=byclass, ...))) { 265 print(noquote(values)) 266 cat("see '?methods' for accessing help and source code\n") 267 } else 268 cat("no methods found\n") 269 270 invisible(x) 271} 272 273getS3method <- function(f, class, optional = FALSE, envir = parent.frame()) 274{ 275 stopifnot(is.character(f), length(f) == 1L) 276 stopifnot(is.character(class), length(class) == 1L) 277 if(!any(f == getKnownS3generics())) { 278 truegf <- findGeneric(f, envir) 279 if(nzchar(truegf)) f <- truegf 280 else { 281 if(optional) return(NULL) 282 else stop(gettextf("no function '%s' could be found", f), domain = NA) 283 } 284 } 285 method <- paste(f, class, sep=".") 286 if(!is.null(m <- get0(method, envir = envir, mode = "function"))) 287 ## FIXME(?): consider tools::nonS3methods(<pkg>) same as isS3method() 288 return(m) 289 ## also look for registered method in namespaces 290 defenv <- 291 if(!is.na(w <- .knownS3Generics[f])) 292 asNamespace(w) 293 else if(f %in% tools:::.get_internal_S3_generics()) 294 .BaseNamespaceEnv 295 else { 296 genfun <- get(f, mode="function", envir = envir) 297 if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) 298 ## assumes the default method is the S3 generic function 299 genfun <- methods::selectMethod(genfun, "ANY") 300 .defenv_for_S3_registry(genfun) 301 } 302 S3Table <- get(".__S3MethodsTable__.", envir = defenv) 303 if(!is.null(m <- get0(method, envir = S3Table, inherits = FALSE))) 304 m 305 else if(optional) 306 NULL 307 else stop(gettextf("S3 method '%s' not found", method), domain = NA) 308} 309 310##' Much in parallel to getS3method(), isS3method() gives TRUE/FALSE, but not an error 311isS3method <- function(method, f, class, envir = parent.frame()) 312{ 313 if(missing(method)) { 314 method <- paste(f, class, sep=".") 315 } else { # determine (f, class) from 'method' 316 f.c <- strsplit(method, ".", fixed=TRUE)[[1]] 317 nfc <- length(f.c) 318 if(nfc < 2 || !is.character(f.c)) 319 return(FALSE) ## stop("Invalid 'method' specification; must be \"<fun>.<class>\"") 320 if(nfc == 2) { 321 f <- f.c[[1L]] 322 class <- f.c[[2L]] 323 } else { ## nfc > 2 : e.g., t.data.frame, is.na.data.frame 324 for(j in 2:nfc) 325 if(isS3method(f = paste(f.c[1:(j-1)], collapse="."), 326 class = paste(f.c[j: nfc ], collapse="."), 327 envir = envir)) 328 return(TRUE) 329 return(FALSE) 330 } 331 } 332 if(!any(f == getKnownS3generics())) { ## either a known generic or found in 'envir' 333 if(!nzchar(f <- findGeneric(f, envir))) 334 return(FALSE) 335 } 336 if(!is.null(m <- get0(method, envir = envir, mode = "function"))) { 337 ## know: f is a knownS3generic, and method m is a visible function 338 pkg <- if(isNamespace(em <- environment(m))) environmentName(em) 339 else if(is.primitive(m)) "base" ## else NULL 340 return(is.na(match(method, tools::nonS3methods(pkg)))) ## TRUE unless an exception 341 } 342 ## also look for registered method in namespaces 343 defenv <- 344 if(!is.na(w <- .knownS3Generics[f])) 345 asNamespace(w) 346 else if(f %in% tools:::.get_internal_S3_generics()) 347 .BaseNamespaceEnv 348 else { 349 genfun <- get(f, mode="function", envir = envir) 350 if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) 351 ## assumes the default method is the S3 generic function 352 genfun <- methods::selectMethod(genfun, "ANY") 353 .defenv_for_S3_registry(genfun) 354 } 355 S3Table <- get(".__S3MethodsTable__.", envir = defenv) 356 ## return 357 exists(method, envir = S3Table, inherits = FALSE) 358} 359 360isS3stdGeneric <- function(f) { 361 bdexpr <- body(if(methods::is(f, "traceable")) f@original else f) 362 ## protect against technically valid but bizarre 363 ## function(x) { { { UseMethod("gen")}}} by 364 ## repeatedly consuming the { until we get to the first non { expr 365 while(is.call(bdexpr) && bdexpr[[1L]] == "{") 366 bdexpr <- bdexpr[[2L]] 367 368 ## We only check if it is a "standard" s3 generic. i.e. the first non-{ 369 ## expression is a call to UseMethod. This will return FALSE if any 370 ## work occurs before the UseMethod call ("non-standard" S3 generic) 371 ret <- is.call(bdexpr) && bdexpr[[1L]] == "UseMethod" 372 if(ret) 373 names(ret) <- bdexpr[[2L]] ## arg passed to UseMethod naming generic 374 ret 375} 376 377getFromNamespace <- 378function(x, ns, pos = -1, envir = as.environment(pos)) 379{ 380 if(missing(ns)) { 381 nm <- attr(envir, "name", exact = TRUE) 382 if(is.null(nm) || !startsWith(nm, "package:")) 383 stop("environment specified is not a package") 384 ns <- asNamespace(substring(nm, 9L)) 385 } else ns <- asNamespace(ns) 386 get(x, envir = ns, inherits = FALSE) 387} 388 389assignInMyNamespace <- 390function(x, value) 391{ 392 f <- sys.function(-1) 393 ns <- environment(f) 394 ## deal with subclasses of "function" 395 ## that may insert an environment in front of the namespace 396 if(isS4(f)) 397 while(!isNamespace(ns)) 398 ns <- parent.env(ns) 399 if(bindingIsLocked(x, ns)) { 400 unlockBinding(x, ns) 401 assign(x, value, envir = ns, inherits = FALSE) 402 w <- options("warn") 403 on.exit(options(w)) 404 options(warn = -1) 405 lockBinding(x, ns) 406 } else assign(x, value, envir = ns, inherits = FALSE) 407 if(!isBaseNamespace(ns)) { 408 ## now look for possible copy as a registered S3 method 409 S3 <- getNamespaceInfo(ns, "S3methods") 410 if(!length(S3)) return(invisible(NULL)) 411 S3names <- S3[, 3L] 412 if(x %in% S3names) { 413 i <- match(x, S3names) 414 genfun <- get(S3[i, 1L], mode = "function", envir = parent.frame()) 415 if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) 416 genfun <- methods::slot(genfun, "default")@methods$ANY 417 defenv <- .defenv_for_S3_registry(genfun) 418 S3Table <- get(".__S3MethodsTable__.", envir = defenv) 419 remappedName <- paste(S3[i, 1L], S3[i, 2L], sep = ".") 420 if(exists(remappedName, envir = S3Table, inherits = FALSE)) 421 assign(remappedName, value, S3Table) 422 } 423 } 424 invisible(NULL) 425} 426 427assignInNamespace <- 428function(x, value, ns, pos = -1, envir = as.environment(pos)) 429{ 430 nf <- sys.nframe() 431 if(missing(ns)) { 432 nm <- attr(envir, "name", exact = TRUE) 433 if(is.null(nm) || !startsWith(nm, "package:")) 434 stop("environment specified is not a package") 435 ns <- asNamespace(substring(nm, 9L)) 436 } else ns <- asNamespace(ns) 437 ns_name <- getNamespaceName(ns) 438 if (nf > 1L) { 439 if(ns_name %in% tools:::.get_standard_package_names()$base) 440 stop("locked binding of ", sQuote(x), " cannot be changed", 441 domain = NA) 442 } 443 if(bindingIsLocked(x, ns)) { 444 in_load <- Sys.getenv("_R_NS_LOAD_") 445 if (nzchar(in_load)) { 446 if(in_load != ns_name) { 447 msg <- 448 gettextf("changing locked binding for %s in %s whilst loading %s", 449 sQuote(x), sQuote(ns_name), sQuote(in_load)) 450 if (! in_load %in% c("Matrix", "SparseM")) 451 warning(msg, call. = FALSE, domain = NA, immediate. = TRUE) 452 } 453 } else if (nzchar(Sys.getenv("_R_WARN_ON_LOCKED_BINDINGS_"))) { 454 warning(gettextf("changing locked binding for %s in %s", 455 sQuote(x), sQuote(ns_name)), 456 call. = FALSE, domain = NA, immediate. = TRUE) 457 } 458 unlockBinding(x, ns) 459 assign(x, value, envir = ns, inherits = FALSE) 460 w <- options("warn") 461 on.exit(options(w)) 462 options(warn = -1) 463 lockBinding(x, ns) 464 } else { 465 assign(x, value, envir = ns, inherits = FALSE) 466 } 467 if(!isBaseNamespace(ns)) { 468 ## now look for possible copy as a registered S3 method 469 S3 <- .getNamespaceInfo(ns, "S3methods") 470 if(!length(S3)) return(invisible(NULL)) 471 S3names <- S3[, 3L] 472 if(x %in% S3names) { 473 i <- match(x, S3names) 474 genfun <- get(S3[i, 1L], mode = "function", envir = parent.frame()) 475 if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) 476 genfun <- methods::slot(genfun, "default")@methods$ANY 477 defenv <- .defenv_for_S3_registry(genfun) 478 S3Table <- get(".__S3MethodsTable__.", envir = defenv) 479 remappedName <- paste(S3[i, 1L], S3[i, 2L], sep = ".") 480 if(exists(remappedName, envir = S3Table, inherits = FALSE)) 481 assign(remappedName, value, S3Table) 482 } 483 } 484 invisible(NULL) 485} 486 487fixInNamespace <- 488function(x, ns, pos = -1, envir = as.environment(pos), ...) 489{ 490 subx <- substitute(x) 491 if (is.name(subx)) 492 subx <- deparse(subx) 493 if (!is.character(subx) || length(subx) != 1L) 494 stop("'fixInNamespace' requires a name") 495 if(missing(ns)) { 496 nm <- attr(envir, "name", exact = TRUE) 497 if(is.null(nm) || !startsWith(nm, "package:")) 498 stop("environment specified is not a package") 499 ns <- asNamespace(substring(nm, 9L)) 500 } else ns <- asNamespace(ns) 501 x <- edit(get(subx, envir = ns, inherits = FALSE), ...) 502 assignInNamespace(subx, x, ns) 503} 504 505getAnywhere <- 506function(x) 507{ 508 if(tryCatch(!is.character(x), error = function(e) TRUE)) 509 x <- as.character(substitute(x)) 510 objs <- list(); where <- character(); visible <- logical() 511 ## first look on search path 512 if(length(pos <- find(x, numeric = TRUE))) { 513 objs <- lapply(pos, function(pos, x) get(x, pos=pos), x=x) 514 where <- names(pos) 515 visible <- rep.int(TRUE, length(pos)) 516 } 517 ## next look for methods: a.b.c.d could be a method for a or a.b or a.b.c 518 if(length(grep(".", x, fixed=TRUE))) { 519 np <- length(parts <- strsplit(x, ".", fixed=TRUE)[[1L]]) 520 for(i in 2:np) { 521 gen <- paste(parts[1L:(i-1)], collapse=".") 522 cl <- paste(parts[i:np], collapse=".") 523 if (gen == "" || cl == "") next 524 ## want to evaluate this in the parent, or the utils namespace 525 ## gets priority. 526 Call <- substitute(getS3method(gen, cl, TRUE), list(gen = gen, cl = cl)) 527 f <- eval.parent(Call) 528 ## Now try to fathom out where it is from. 529 ## f might be a special, not a closure, and not have an environment, 530 if(!is.null(f) && !is.null(environment(f))) { 531 ev <- topenv(environment(f), baseenv()) 532 nmev <- if(isNamespace(ev)) getNamespaceName(ev) else NULL 533 objs <- c(objs, list(f)) 534 msg <- paste("registered S3 method for", gen) 535 if(!is.null(nmev)) 536 msg <- paste(msg, "from namespace", nmev) 537 where <- c(where, msg) 538 visible <- c(visible, FALSE) 539 } 540 } 541 } 542 ## now look in loaded namespaces 543 for(i in loadedNamespaces()) { 544 ns <- asNamespace(i) 545 if(exists(x, envir = ns, inherits = FALSE)) { 546 f <- get(x, envir = ns, inherits = FALSE) 547 objs <- c(objs, list(f)) 548 where <- c(where, paste0("namespace:", i)) 549 visible <- c(visible, FALSE) 550 } 551 } 552 # now check for duplicates 553 ln <- length(objs) 554 dups <- rep.int(FALSE, ln) 555 if(ln > 1L) 556 for(i in 2L:ln) 557 for(j in 1L:(i-1L)) 558 if(identical(objs[[i]], objs[[j]], 559 ignore.environment = TRUE)) { 560 dups[i] <- TRUE 561 break 562 } 563 structure(list(name=x, objs=objs, where=where, visible=visible, dups=dups), 564 class = "getAnywhere") 565} 566 567print.getAnywhere <- 568function(x, ...) 569{ 570 n <- sum(!x$dups) 571 if(n == 0L) { 572 cat("no object named", sQuote(x$name), "was found\n") 573 } else if (n == 1L) { 574 cat("A single object matching", sQuote(x$name), "was found\n") 575 cat("It was found in the following places\n") 576 cat(paste0(" ", x$where), sep="\n") 577 cat("with value\n\n") 578 print(x$objs[[1L]]) 579 } else { 580 cat(n, "differing objects matching", sQuote(x$name), 581 "were found\n") 582 cat("in the following places\n") 583 cat(paste0(" ", x$where), sep="\n") 584 cat("Use [] to view one of them\n") 585 } 586 invisible(x) 587} 588 589`[.getAnywhere` <- 590function(x, i) 591{ 592 if(!is.numeric(i)) stop("only numeric indices can be used") 593 if(length(i) == 1L) x$objs[[i]] 594 else x$objs[i] 595} 596 597argsAnywhere <- 598function(x) 599{ 600 if(tryCatch(!is.character(x), error = function(e) TRUE)) 601 x <- as.character(substitute(x)) 602 fs <- getAnywhere(x) 603 if (sum(!fs$dups) == 0L) 604 return(NULL) 605 if (sum(!fs$dups) > 1L) 606 sapply(fs$objs[!fs$dups], 607 function(f) if (is.function(f)) args(f)) 608 else args(fs$objs[[1L]]) 609} 610 611.defenv_for_S3_registry <- 612function(genfun) 613{ 614 if (typeof(genfun) == "closure") { 615 lookup <- Sys.getenv("_R_S3_METHOD_LOOKUP_USE_TOPENV_AS_DEFENV_", 616 "TRUE") 617 lookup <- tools:::config_val_to_logical(lookup) 618 if(lookup) { 619 topenv(environment(genfun)) 620 } else { 621 environment(genfun) 622 } 623 } 624 else .BaseNamespaceEnv 625} 626