Nothing
## WARNING:
## This code is a complete hack, may or may not work, etc..
## Use your own risk. You have been warned.
##
## This file is generated from ../noweb/codetools.nw; make changes there.
##
## Environment utilities
##
.BaseEnv <- if (exists("baseenv")) baseenv() else NULL
.EmptyEnv <- if (exists("emptyenv")) emptyenv() else NULL
is.emptyenv <- function(e) identical(e, .EmptyEnv)
is.baseenv <- function(e) identical(e, .BaseEnv)
mkHash <- function() new.env(hash = TRUE, parent = .EmptyEnv)
##
## Code walker
##
walkCode <- function(e, w = makeCodeWalker()) {
if (typeof(e) == "language") {
if (typeof(e[[1]]) %in% c("symbol", "character")) {
h <- w$handler(as.character(e[[1]]), w)
if (! is.null(h)) h(e, w)
else w$call(e, w)
}
else w$call(e, w)
}
else w$leaf(e, w)
}
makeCodeWalker <- function(...,
handler = function (v, w) NULL,
call = function(e, w)
for (ee in as.list(e))
if (! missing(ee)) walkCode(ee, w),
leaf = function(e, w) print(e))
list(handler = handler, call = call, leaf = leaf, ...)
##
## Call tree display
##
showTree <- function(e, write = cat) {
w <- makeCodeWalker(call = showTreeCall, leaf = showTreeLeaf,
write = write)
walkCode(e, w)
w$write("\n")
}
showTreeCall <- function(e, w) {
w$write("(")
walkCode(e[[1]], w)
for (a in as.list(e[-1])) {
w$write(" ")
if (missing(a))
w$write("<Missing>")
else
walkCode(a, w)
}
w$write(")")
}
showTreeLeaf <- function(e, w) {
if (typeof(e) == "symbol") {
if (e == "(") w$write("\"(\"")
else if (e == "{") w$write("\"{\"")
else w$write(e)
}
else w$write(deparse(e))
}
##
## Call with current continuation
##
if (! exists("callCC"))
callCC <- function(fun) {
value <- NULL
delayedAssign("throw", return(value))
fun(function(v) { value <<- v; throw })
}
##
## Constant folding
##
makeConstantFolder <- function(...,
leaf = foldLeaf,
handler = function(v, w)
if (w$foldable(v, w)) foldCall,
call = function(e, w) exitFolder(e, w),
exit = function(e, w)
stop0(paste("not a foldable expression:",
deparse(e, width.cutoff = 500))),
isLocal = function(v, w) FALSE,
foldable = isFoldable,
isConstant = isConstantValue,
signal = function(e, msg, w) warning0(msg))
list(handler = handler, call = call, exit = exit, leaf = leaf,
isLocal = isLocal, foldable = isFoldable,
isConstant = isConstant, signal = signal, ...)
exitFolder <- function(e, w) {
w$exit(e, w)
stop0("constant folding cannot continue")
}
constantFold <- function(e, env = NULL, fail = NULL) {
job <- function(exit) {
isLocal <- function(v, w) as.character(v) %in% env
doExit <- function(e, w) exit(fail)
w <- makeConstantFolder(isLocal = isLocal, exit = doExit)
walkCode(e, w)
}
callCC(job)
}
constantFoldEnv <- function(e, env = .GlobalEnv, fail = NULL) {
isLocal <- function(v, w) {
vname <- as.character(v)
while (! identical(env, .GlobalEnv)) {
if (exists(vname, env, inherits = FALSE))
return(TRUE)
env <- parent.env(env)
}
FALSE
}
job <- function(exit) {
doExit <- function(e, w) exit(fail)
w <- makeConstantFolder(isLocal = isLocal, exit = doExit)
walkCode(e, w)
}
tryCatch(callCC(job), error = function(e) fail)
}
isConstantValue <- function(v, w)
is.null(v) ||
(is.null(attributes(v)) && is.atomic(v)) ||
(is.list(v) && (identical(v, .Platform) || identical(v, .Machine)))
isFoldable <- function(v, w)
((typeof(v) == "symbol" || typeof(v) == "character") &&
as.character(v) %in% foldFuns && ! w$isLocal(v, w))
foldFuns <- c("+", "-", "*", "/", "^", "(",
">", ">=", "==", "!=", "<", "<=", "||", "&&", "!",
"|", "&", "%%",
"sqrt", "log", "exp",
"c", "as.integer", "vector", "integer","numeric","character",
"rep",
":",
"cos", "sin", "tan", "acos", "asin", "atan", "atan2",
"is.R", "$", "[", "[[")
constNames <- c("pi", "T", "F", ".Platform", ".Machine")
foldLeaf <- function(e, w) {
if (is.name(e) && as.character(e) %in% constNames && ! w$isLocal(e, w))
e <- get(as.character(e), envir = .BaseEnv)
if (! w$isConstant(e)) exitFolder(e, w)
e
}
foldCall <- function(e, w) {
fname <- as.character(e[[1]])
if (fname == "$") {
args <- list(walkCode(e[[2]], w), e[[3]])
foldable <- w$isConstant(args[[1]], w)
}
else {
args <- lapply(e[-1], function(e) walkCode(e, w))
foldable <- all(sapply(args, w$isConstant, w))
}
if (foldable) {
msg <- try({ v <- do.call(fname, args); NULL }, silent = TRUE)
if (! is.null(msg)) {
w$signal(e, msg, w)
exitFolder(e, w)
}
else if (w$isConstant(v, w)) v
else exitFolder(e, w)
}
else exitFolder(e, w)
}
##
## Finding local variables
##
makeLocalsCollector <- function(...,
leaf = function (e, w) character(0),
handler = getCollectLocalsHandler,
isLocal = function(v, w) FALSE,
exit = function(e, msg, w) stop0(msg),
collect = function(v, e, w) print(v))
makeCodeWalker(leaf = leaf, handler = handler, collect = collect,
isLocal = isLocal, exit = exit)
collectLocals <- function(e, collect) {
w <- makeLocalsCollector(collect = collect)
walkCode(e, w)
}
getCollectLocalsHandler <- function(v, w) {
switch(v,
"=" =,
"<-" = collectLocalsAssignHandler,
"for" = collectLocalsForHandler,
"function" =,
"~" = function(e, w) character(0),
"local" = if (! w$isLocal(v, w))
collectLocalsLocalHandler,
## **** could add handler for bquote() here that looks at the .()'s,
## **** ..(), and extra args, but creating locals there is not very
## **** sensible, so handle like quote() for now.
"bquote" =,
"expression" =,
"Quote" =,
"quote" = if (! w$isLocal(v, w))
function(e, w) character(0),
"delayedAssign" =,
"assign" = function(e, w)
if (length(e) == 3 && is.character(e[[2]]) &&
length(e[[2]]) == 1) {
w$collect(e[[2]], e, w)
walkCode(e[[3]], w)
}
else for (a in dropMissings(e[-1])) walkCode(a, w))
}
dropMissings <- function(x) {
lx <- as.list(x)
ix <- rep(TRUE, length(x))
for (i in seq_along(ix)) {
a <- lx[[i]]
if (missing(a)) ix[i] <- FALSE
}
lx[ix]
}
collectLocalsAssignHandler <- function(e, w) {
w$collect(getAssignedVar(e), e, w)
walkCode(e[[2]], w)
walkCode(e[[3]], w)
}
collectLocalsForHandler <- function(e, w) {
signal <- function(msg) w$exit(e, msg, w)
w$collect(as.character(checkSymOrString(e[[2]], signal)), e, w)
walkCode(e[[3]], w)
walkCode(e[[4]], w)
}
checkSymOrString <- function(e, signal = stop) {
type <- typeof(e)
if (type == "symbol" || type == "character") e
else signal("not a symbol or string")
}
collectLocalsLocalHandler <- function(e, w) {
if (length(e) == 2) # no explicit env
character(0)
else for (a in dropMissings(e[-1])) walkCode(a, w)
}
findLocalsList <- function(elist, envir = .BaseEnv) {
localStopFuns <- c("expression", "quote", "Quote", "local")
if (is.character(envir))
locals <- envir
else
locals <- localStopFuns[! sapply(localStopFuns,isBaseVar, envir)]
specialSyntaxFuns <- c("~", "<-", "=", "for", "function")
sf <- unique(c(locals, localStopFuns))
nsf <- length(sf)
collect <- function(v, e, w) assign(v, TRUE, envir = env)
isLocal <- function(v, w) as.character(v) %in% sf
w <- makeLocalsCollector(collect = collect, isLocal = isLocal)
repeat {
env <- mkHash()
for (e in elist) walkCode(e, w)
isloc <- sapply(sf, exists, envir = env, inherits = FALSE)
last.nsf <- nsf
sf <- unique(c(locals, sf[isloc]))
nsf <- length(sf)
if (last.nsf == nsf) {
vals <- ls(env, all.names = TRUE)
rdsf <- vals %in% specialSyntaxFuns
if (any(rdsf))
warning0(paste("local assignments to syntactic functions:",
vals[rdsf]))
return(vals)
}
}
}
findLocals <- function(e, envir = .BaseEnv)
findLocalsList(list(e), envir)
findOwnerEnv <- function(v, env, stop = NA, default = NA) {
while (! identical(env, stop))
if (exists(v, envir = env, inherits = FALSE))
return(env)
else if (is.emptyenv(env))
return(default)
else env <- parent.env(env)
default
}
isBaseVar <- function (v, env) {
e <- findOwnerEnv(v, env)
is.baseenv(e) || identical(e, .BaseNamespaceEnv) || v == "@<-"
}
findFuncLocals <- function(formals, body)
findLocalsList(c(list(body), dropMissings(formals)))
##
## Assignment handling
##
getAssignedVar <- function(e) {
v <- e[[2]]
if (missing(v))
stop0(paste("bad assignment:", pasteExpr(e)))
else if (typeof(v) %in% c("symbol", "character"))
as.character(v)
else {
while (typeof(v) == "language") {
if (length(v) < 2)
stop0(paste("bad assignment:", pasteExpr(e)))
v <- v[[2]]
if (missing(v))
stop0(paste("bad assignment:", pasteExpr(e)))
}
if (typeof(v) != "symbol")
stop0(paste("bad assignment:", pasteExpr(e)))
as.character(v)
}
}
evalseq <- function(e) {
if (typeof(e) == "language") {
v <- evalseq(e[[2]])
e[[2]] <- as.name("*tmp*")
c(v, list(e))
}
else list(e)
}
apdef <- function(e) {
v <- NULL
tmp <- as.name("*tmp*")
tmpv <- as.name("*tmpv*")
while (typeof(e) == "language") {
ef <- e
ef[[1]] <- makeAssgnFcn(e[[1]])
if (typeof(ef[[2]]) == "language")
ef[[2]] <- tmp
ef$value <- tmpv
v <- c(v, list(ef))
e <- e[[2]]
}
v
}
makeAssgnFcn <- function(fun) {
if (typeof(fun) == "symbol")
as.name(paste0(as.character(fun), "<-"))
else {
if (getRversion() >= "2.13.0" &&
typeof(fun) == "language" && typeof(fun[[1]]) == "symbol" &&
as.character(fun[[1]]) %in% c("::", ":::") &&
length(fun) == 3 && typeof(fun[[3]]) == "symbol") {
fun[[3]] <- as.name(paste0(as.character(fun[[3]]), "<-"))
fun
}
else
stop(sQuote(deparse(fun)),
" is not a valid function in complex assignments")
}
}
flattenAssignment <- function(e) {
if (typeof(e) == "language")
list(evalseq(e[[2]]), apdef(e))
else list(NULL, NULL)
}
##
## Collecting usage information
##
makeUsageCollector <- function(fun, ..., name = NULL,
enterLocal = doNothing,
enterGlobal = doNothing,
enterInternal = doNothing,
startCollectLocals = doNothing,
finishCollectLocals = doNothing,
warn = warning0,
signal = signalUsageIssue) {
if (typeof(fun) == "closure")
env <- environment(fun)
else
env <- .GlobalEnv
makeCodeWalker(..., name = name,
enterLocal = enterLocal,
enterGlobal = enterGlobal,
enterInternal = enterInternal,
startCollectLocals = startCollectLocals,
finishCollectLocals = finishCollectLocals,
warn = warn,
signal = signal,
leaf = collectUsageLeaf,
call = collectUsageCall,
handler = getCollectUsageHandler,
globalenv = env,
env = env,
name = NULL,
srcfile = NULL,
frow = NULL,
lrow = NULL,
isLocal = collectUsageIsLocal)
}
collectUsage <- function(fun, name = "<anonymous>", ...) {
w <- makeUsageCollector(fun, ...)
collectUsageFun(name, formals(fun), body(fun), w)
}
collectUsageLeaf <- function(v, w) {
if (typeof(v) == "symbol") {
vn <- as.character(v)
if (v == "...")
w$signal("... may be used in an incorrect context", w)
else if (isDDSym(v)) {
if (w$isLocal("...", w))
w$enterLocal("variable", "...", v, w)
else
w$signal(paste(v, "may be used in an incorrect context"), w)
}
else if (w$isLocal(vn, w))
w$enterLocal("variable", vn, v, w)
else if (! vn %in% c("*tmp*", "*tmpv*"))
w$enterGlobal("variable", vn, v, w)
}
}
collectUsageArgs <- function(e, w) {
for (a in dropMissings(e[-1]))
if (typeof(a) == "symbol" && a == "...") {
if (w$isLocal("...", w))
w$enterLocal("variable", "...", a, w)
else
w$signal(paste(a, "may be used in an incorrect context:",
pasteExpr(e)), w)
}
else walkCode(a, w)
}
collectUsageCall <- function(e, w) {
if (typeof(e[[1]]) %in% c("symbol", "character")) {
fn <- as.character(e[[1]])
if (w$isLocal(fn, w))
w$enterLocal("function", fn, e, w)
else w$enterGlobal("function", fn, e, w)
}
else walkCode(e[[1]], w)
collectUsageArgs(e, w)
}
collectUsageFun <- function(name, formals, body, w) {
w$name <- c(w$name, name)
parnames <- names(formals)
locals <- findFuncLocals(formals, body)
w$env <- new.env(hash = TRUE, parent = w$env)
for (n in c(parnames, locals))
assign(n, TRUE, w$env)
w$startCollectLocals(parnames, locals, w)
for (a in dropMissings(formals)) walkCode(a, w)
walkCode(body, w)
w$finishCollectLocals(w)
}
signalUsageIssue <- function(m, w) {
if (!is.null(w$frow) && !is.na(w$frow)) {
fname <- w$srcfile
if (w$frow == w$lrow)
loc <- paste(" (", fname, ":", w$frow, ")", sep = "")
else loc <- paste(" (", fname, ":", w$frow, "-", w$lrow, ")", sep = "")
}
else loc <- NULL
w$warn(paste(paste(w$name, collapse = " : "), ": ", m, loc, "\n", sep = ""))
}
# **** is this the right handling of ..n things?
# **** signal (possible) error if used in wrong context?
# **** also need error for ... when not present
# **** maybe better done in leaf?
collectUsageIsLocal <- function(v, w) {
if (isDDSym(v)) v <- "..."
! is.baseenv(findOwnerEnv(v, w$env, stop = w$globalenv,
default = .BaseEnv))
}
doNothing <- function(...) NULL
##
## Usage collectors for some standard functions
##
collectUsageHandlers <- mkHash()
# 'where' is ignored for now
addCollectUsageHandler <- function(v, where, fun)
assign(v, fun, envir = collectUsageHandlers)
getCollectUsageHandler <- function(v, w)
if (exists(v, envir = collectUsageHandlers, inherits = FALSE) &&
(isBaseVar(v, w$env) ||
isStatsVar(v, w$env) || isUtilsVar(v, w$env) || # **** for now
v == "Quote" )) # **** yet another glorious hack!!!
get(v, envir = collectUsageHandlers)
##**** this is (yet another) temporary hack
isStatsVar <- function(v, env) {
e <- findOwnerEnv(v, env)
if (! identical(e, NA) &&
exists(v, envir = e, inherits = FALSE, mode = "function")) {
f <- get(v, envir = e, inherits = FALSE, mode = "function")
identical(environment(f), getNamespace("stats"))
}
else FALSE
}
isUtilsVar <- function(v, env) {
e <- findOwnerEnv(v, env)
if (! identical(e, NA) &&
exists(v, envir = e, inherits = FALSE, mode = "function")) {
f <- get(v, envir = e, inherits = FALSE, mode = "function")
identical(environment(f), getNamespace("utils"))
}
else FALSE
}
isSimpleFunDef <- function(e, w)
typeof(e[[2]]) != "language" && typeof(e[[3]]) == "language" &&
typeof(e[[3]][[1]]) %in% c("symbol", "character") &&
e[[3]][[1]] == "function" && isBaseVar("function", w$env)
isClosureFunDef <- function(e, w)
typeof(e[[2]]) != "language" && typeof(e[[3]]) == "closure"
checkDotsAssignVar <- function(v, w) {
if (v == "...") {
w$signal("... may be used in an incorrect context", w)
FALSE
}
else if (isDDSym(v)) {
w$signal(paste(v, "may be used in an incorrect context"), w)
FALSE
}
else TRUE
}
#**** proceeds even if "..." or "..1", etc--is that right?
local({
h <- function(e, w) {
w$enterGlobal("function", as.character(e[[1]]), e, w)
v <- getAssignedVar(e)
checkDotsAssignVar(v, w)
w$enterLocal("<-", v, e, w)
if (isSimpleFunDef(e, w))
collectUsageFun(v, e[[3]][[2]], e[[3]][[3]], w)
else if (isClosureFunDef(e, w)) { ## to handle inlined S4 methods
fun <- e[[3]]
w$globalenv <- environment(fun)
w$env = environment(fun)
collectUsageFun(v, formals(fun), body(fun), w)
}
else {
if (typeof(e[[2]]) == "language") {
fa <- flattenAssignment(e[[2]])
for (a in fa)
for (b in a) walkCode(b, w)
}
walkCode(e[[3]], w)
}
}
addCollectUsageHandler("<-", "base", h)
addCollectUsageHandler("=", "base", h)
})
#**** would be better to use match.call in most of these
#**** proceeds even if "..." or "..1", etc--is that right?
addCollectUsageHandler("<<-", "base", function(e, w) {
w$enterGlobal("function", "<<-", e, w)
v <- getAssignedVar(e)
checkDotsAssignVar(v, w)
if (w$isLocal(v, w))
w$enterLocal("<<-", v, e, w)
else w$enterGlobal("<<-", v, e, w)
if (typeof(e[[2]]) == "language") {
fa <- flattenAssignment(e[[2]])
for (a in fa)
for (b in a) walkCode(b, w)
}
walkCode(e[[3]], w)
})
addCollectUsageHandler("for", "base", function(e, w) {
w$enterGlobal("function", "for", e, w)
v <- as.character(e[[2]])
w$enterLocal("for", v, e, w)
walkCode(e[[3]], w)
walkCode(e[[4]], w)
})
addCollectUsageHandler("{", "base", function(e, w) {
w$enterGlobal("function", "{", e, w)
w$srcfile <- attr(e, "srcfile")$filename
if (length(e)>1){
for ( i in 2 : length(e)){
if ( !is.null(attr(e, "srcref")[[i]])){
w$frow <- attr(e, "srcref")[[i]][[1]]
w$lrow <- attr(e, "srcref")[[i]][[3]]
}
walkCode(e[[i]], w)
}
}
})
#**** is this the right way to handle :: and ::: ??
#**** maybe record package/name space?
local({
h <- function(e, w)
w$enterGlobal("function", as.character(e[[1]]), e, w)
addCollectUsageHandler("~", "base", h)
addCollectUsageHandler("quote", "base", h)
addCollectUsageHandler("Quote", "methods", h)
addCollectUsageHandler("expression", "base", h)
addCollectUsageHandler("::", "base", h)
addCollectUsageHandler(":::", "base", h)
})
#**** add counter to anonymous functions to distinguish??
addCollectUsageHandler("function", "base", function(e, w)
collectUsageFun("<anonymous>", e[[2]], e[[3]], w))
addCollectUsageHandler("local", "base", function(e, w) {
w$enterGlobal("function", "local", e, w)
if (length(e) == 2)
collectUsageFun("<local>", NULL, e[[2]], w)
else collectUsageArgs(e, w)
})
addCollectUsageHandler("assign", "base", function(e, w) {
w$enterGlobal("function", "assign", e, w)
if (length(e) == 3 && is.character(e[[2]]) && length(e[[2]]) == 1) {
w$enterLocal("<-", e[[2]], e, w)
walkCode(e[[3]], w)
}
else collectUsageArgs(e, w)
})
addCollectUsageHandler("with", "base", function(e, w) {
w$enterGlobal("function", "with", e, w)
if (identical(w$skipWith, TRUE))
walkCode(e[[2]], w)
else collectUsageArgs(e, w)
})
local({
h <- function(e, w) {
w$enterGlobal("function", as.character(e[[1]]), e, w)
walkCode(e[[2]], w)
}
addCollectUsageHandler("$", "base", h)
addCollectUsageHandler("@", "base", h)
})
local({
h <- function(e, w) {
w$enterGlobal("function", as.character(e[[1]]), e, w)
walkCode(e[[2]], w)
walkCode(e[[4]], w)
}
addCollectUsageHandler("$<-", "base", h)
addCollectUsageHandler("@<-", "base", h)
})
addCollectUsageHandler(".Internal", "base", function(e, w) {
w$enterGlobal("function", ".Internal", e, w)
if (length(e) != 2)
w$signal(paste("wrong number of arguments to '.Internal':",
pasteExpr(e)), w)
else if (typeof(e[[2]]) == "language") {
w$enterInternal(e[[2]][[1]], e[[2]], w)
collectUsageArgs(e[[2]], w)
}
else w$signal(paste("bad argument to '.Internal':", pasteExpr(e[[2]])), w)
})
addCollectUsageHandler("substitute", "base", function(e, w) {
w$enterGlobal("function", "substitute", e, w)
if (length(e) > 3)
w$signal("wrong number of arguments to 'substitute'", w)
if (length(e) == 3) {
a <- e[[3]]
if (! missing(a)) walkCode(a, w)
}
})
addCollectUsageHandler("bquote", "base", function(e, w) {
w$enterGlobal("function", "bquote", e, w)
if (! anyDots(e)) {
e <- tryCatch(match.call(base::bquote, e), error = function(e) NULL)
if (! is.null(e) && length(e) >= 2) {
## check .() and ..() arguments in -expr`, but only if
## 'where' is not supplied
if (! "where" %in% names(e)) {
bqchk <- function(e) {
if (is.call(e)) {
## really should only allow for ..() is 'splice =
## TRUE' is given, but that is awkward to check
if (is.name(e[[1L]]) && length(e) == 2 &&
as.character(e[[1]]) %in% c(".", ".."))
walkCode(e[[2]], w)
else lapply(e, bqchk)
}
}
bqchk(e[[2]])
}
## check usage in any additional arguments
for (a in as.list(e)[-(1 : 2)])
walkCode(a, w)
}
}
})
addCollectUsageHandler("library", "base", function(e, w) {
w$enterGlobal("function", "library", e, w)
if (length(e) > 2)
for(a in dropMissings(e[-(1:2)])) walkCode(a, w)
})
addCollectUsageHandler("require", "base", function(e, w) {
w$enterGlobal("function", "require", e, w)
if (length(e) > 2)
for(a in dropMissings(e[-(1:2)])) walkCode(a, w)
})
addCollectUsageHandler("data", "utils", function(e, w) {
w$enterGlobal("function", "data", e, w)
})
mkLinkHandler <- function(family, okLinks) {
function(e, w) {
w$enterGlobal("function", family, e, w)
if (length(e) >= 2) {
if (is.character(e[[2]])) {
if (! (e[[2]] %in% okLinks))
w$signal(paste("link", sQuote(e[[2]]), "not available for",
sQuote(family)), w)
}
else if (! is.name(e[[2]]) || ! as.character(e[[2]]) %in% okLinks)
walkCode(e[[2]], w)
}
}
}
addCollectUsageHandler("detach", "base", function(e, w) {
w$enterGlobal("function", "detach", e, w)
if (length(e) > 2)
for(a in dropMissings(e[-(1:2)])) walkCode(a, w)
})
addCollectUsageHandler("binomial", "stats",
mkLinkHandler("binomial",
c("logit", "probit", "cloglog",
"cauchit", "log")))
addCollectUsageHandler("gaussian", "stats",
mkLinkHandler("gaussian",
c("inverse", "log", "identity")))
addCollectUsageHandler("Gamma", "stats",
mkLinkHandler("Gamma",
c("inverse", "log", "identity")))
addCollectUsageHandler("poisson", "stats",
mkLinkHandler("poisson",
c("log", "identity", "sqrt")))
addCollectUsageHandler("quasibinomial", "stats",
mkLinkHandler("quasibinomial",
c("logit", "probit", "cloglog",
"cauchit", "log")))
addCollectUsageHandler("quasipoisson", "stats",
mkLinkHandler("quasipoisson",
c("log", "identity", "sqrt")))
addCollectUsageHandler("quasi", "stats", function(e, w) {
w$enterGlobal("function", "quasi", e, w)
# **** don't look at arguments for now. Need to use match.call
# **** to get this right and trap errors. Later ...
})
addCollectUsageHandler("if", "base", function(e, w) {
w$enterGlobal("function", "if", e, w)
test <- constantFoldEnv(e[[2]], w$env)
if (is.logical(test) && length(test) == 1 && ! is.na(test)) {
walkCode(e[[2]], w)
if (test) walkCode(e[[3]], w)
else if (length(e) > 3) walkCode(e[[4]], w)
}
else collectUsageArgs(e, w)
})
##
## Finding global variables
##
findGlobals <- function(fun, merge = TRUE) {
vars <- mkHash()
funs <- mkHash()
enter <- function(type, v, e, w)
if (type == "function")
assign(v, TRUE, funs)
else assign(v, TRUE, vars)
collectUsage(fun, enterGlobal = enter)
fnames <- ls(funs, all.names = TRUE)
vnames <- ls(vars, all.names = TRUE)
if (merge)
sort(unique(c(vnames, fnames)))
else list(functions = fnames, variables = vnames)
}
##
## Checking function and variable usage
##
checkUsageStartLocals <- function(parnames, locals, w) {
env <- w$env
nplocals <- locals[! locals %in% parnames]
attr(env, "checkUsageFrame") <- env # for sanity check
mkentry <- function(parameter) {
entry <- mkHash()
assign("parameter", parameter, envir = entry)
assign("assigns", 0, envir = entry)
assign("varuses", 0, envir = entry)
assign("funuses", 0, envir = entry)
assign("funforms", NULL, envir = entry)
assign("loopvars", 0, envir = entry)
assign("srcinfo", NULL, envir = entry)
entry
}
for (v in parnames) assign(v, mkentry(TRUE), envir = env)
for (v in nplocals) assign(v, mkentry(FALSE), envir = env)
}
getLocalUsageEntry <- function(vn, w) {
env <- findOwnerEnv(vn, w$env, stop = w$globalenv, default = .BaseEnv)
if (is.baseenv(env)) stop("no local variable entry")
if (! identical(env, attr(env, "checkUsageFrame")))
stop("sanity check on local usage frame failed")
entry <- get(vn, envir = env, inherits = FALSE)
if (! is.environment(entry)) stop("bad local variable entry")
entry
}
getLocalUsageValue <- function(vn, which, w)
get(which, getLocalUsageEntry(vn, w), inherits = FALSE)
setLocalUsageValue <- function(vn, which, value, w)
assign(which, value, envir = getLocalUsageEntry(vn, w))
incLocalUsageValue <- function(vn, which, w) {
entry <- getLocalUsageEntry(vn, w)
value <- get(which, entry, inherits = FALSE)
assign(which, value + 1, entry)
}
incLocalSrcInfo <- function(vn, w) {
entry <- getLocalUsageEntry(vn, w)
value <- get("srcinfo", entry, inherits = FALSE)
new <- list(srcfile = if (is.null(w$srcfile)) NA_character_ else w$srcfile,
frow = if (is.null(w$frow)) NA_integer_ else w$frow,
lrow = if (is.null(w$lrow)) NA_integer_ else w$lrow)
new <- as.data.frame(new, stringsAsFactors = FALSE)
if (is.null(value))
value <- new
else
value <- rbind(value, new)
assign("srcinfo", value, entry)
}
addLocalFunDef <- function(vn, e, w) {
entry <- getLocalUsageEntry(vn, w)
value <- get("funforms", entry, inherits = FALSE)
assign("funforms", c(value, list(e[[3]][[2]])), entry)
}
checkUsageEnterLocal <- function(type, n, e, w) {
if (type %in% c("<-", "<<-") && isSimpleFunDef(e, w))
type <- "fundef"
switch(type,
"<-" =,
"<<-" = incLocalUsageValue(n, "assigns", w),
"variable" = incLocalUsageValue(n, "varuses", w),
"function" = incLocalUsageValue(n, "funuses", w),
"for" = incLocalUsageValue(n, "loopvars", w),
"fundef" = addLocalFunDef(n, e, w))
incLocalSrcInfo(n,w)
}
suppressVar <- function(n, suppress) {
if (is.logical(suppress)) {
if (suppress) TRUE else FALSE
}
else n %in% suppress
}
#**** need test code
#**** merge warnings?
checkUsageFinishLocals <- function(w) {
vars <- ls(w$env, all.names = TRUE)
for (v in vars) {
if (! suppressVar(v, w$suppressLocal)) {
parameter <- getLocalUsageValue(v, "parameter", w)
assigns <- getLocalUsageValue(v, "assigns", w)
varuses <- getLocalUsageValue(v, "varuses", w)
funuses <- getLocalUsageValue(v, "funuses", w)
loopvars <- getLocalUsageValue(v, "loopvars", w)
funforms <- getLocalUsageValue(v, "funforms", w)
uses <- max(varuses, funuses, loopvars)
srcinfo <- getLocalUsageValue(v, "srcinfo", w)
w$srcfile <- srcinfo[1,"srcfile"]
w$frow <- srcinfo[1,"frow"]
w$lrow <- srcinfo[1,"lrow"]
if (parameter) {
if (! suppressVar(v, w$suppressParamAssigns) && assigns > 0)
w$signal(paste("parameter", sQuote(v),
"changed by assignment"), w)
else if (! suppressVar(v, w$suppressParamUnused) &&
uses == 0 && v != "...")
w$signal(paste("parameter", sQuote(v), "may not be used"),
w)
}
else {
if (uses == 0) {
if (! suppressVar(v, w$suppressLocalUnused))
w$signal(paste("local variable", sQuote(v),
"assigned but may not be used"), w)
}
else if (funuses > 0 && is.null(funforms)) {
if (! suppressVar(v, w$suppressNoLocalFun))
w$signal(paste("local variable", sQuote(v),
"used as function with no apparent",
"local function definition"), w)
}
}
if (! suppressVar(v, w$suppressFundefMismatch) &&
length(funforms) > 1) {
first <- funforms[[1]]
nfirst <- names(first)
for (d in funforms[-1])
if (! identical(first, d) ||
! identical(nfirst, names(d))) {
w$signal(paste("multiple local function",
"definitions for", sQuote(v),
"with different formal arguments"), w)
break
}
}
}
}
}
#**** warn if non-function used as variable (most likely get false positives)
#**** merge warnings?
checkUsageEnterGlobal <- function(type, n, e, w) {
if (type == "function") {
if (exists(n, envir = w$globalenv, mode = "function")) {
# **** better call check here
def <- get(n, envir = w$globalenv, mode = "function")
if (typeof(def) == "closure")
checkCall(def, e, function(m) w$signal(m, w))
else {
isBuiltin <- typeof(def) == "builtin"
checkPrimopCall(n, e, isBuiltin, function(m) w$signal(m, w))
}
}
else if (! suppressVar(n, w$suppressUndefined))
w$signal(paste("no visible global function definition for",
sQuote(n)), w)
}
else if (type == "variable") {
if (! exists(n, w$globalenv) && ! suppressVar(n, w$suppressUndefined))
w$signal(paste("no visible binding for global variable",
sQuote(n)), w)
}
else if (type == "<<-") {
if (! exists(n, w$globalenv))
w$signal(paste("no visible binding for '<<-' assignment to",
sQuote(n)), w)
}
}
dfltSuppressUndefined <- c(".Generic", ".Method", ".Class",
".split.valid.screens", ".split.cur.screen", ".split.saved.pars",
".split.screens", ".split.par.list", "last.dump")
#**** merge undefined variable warnings per top level function (at least)
#**** allow complete suppress or by name for all??
checkUsage <- function(fun, name = "<anonymous>",
report = cat,
all = FALSE,
suppressLocal = FALSE,
suppressParamAssigns = ! all,
suppressParamUnused = !all,
suppressFundefMismatch = FALSE,
suppressLocalUnused = FALSE,
suppressNoLocalFun = ! all,
skipWith = FALSE,
suppressUndefined = dfltSuppressUndefined,
suppressPartialMatchArgs = TRUE) {
if (is.null(getOption("warnPartialMatchArgs")))
options(warnPartialMatchArgs = FALSE)
if (! suppressPartialMatchArgs) {
oldOpts <- options(warnPartialMatchArgs = TRUE)
on.exit(options(oldOpts))
}
tryCatch(collectUsage(fun, name = name,
warn = report,
suppressLocal = suppressLocal,
suppressParamAssigns = suppressParamAssigns,
suppressParamUnused = suppressParamUnused,
suppressFundefMismatch = suppressFundefMismatch,
suppressLocalUnused = suppressLocalUnused,
suppressNoLocalFun = suppressNoLocalFun,
skipWith = skipWith,
enterGlobal = checkUsageEnterGlobal,
enterLocal = checkUsageEnterLocal,
startCollectLocals = checkUsageStartLocals,
finishCollectLocals = checkUsageFinishLocals,
suppressUndefined = suppressUndefined,
suppressPartialMatchArgs = suppressPartialMatchArgs),
error = function(e) {
report(paste0(name, ": Error while checking: ",
conditionMessage(e), "\n"))
})
invisible(NULL)
}
checkUsageEnv <- function(env, ...) {
for (n in ls(env, all.names=TRUE)) {
v <- get(n, envir = env)
if (typeof(v)=="closure")
checkUsage(v, name = n, ...)
}
}
checkUsagePackage <- function(pack, ...) {
pname <- paste("package", pack, sep = ":")
if (! pname %in% search())
stop("package must be loaded")
if (pack %in% loadedNamespaces())
checkUsageEnv(getNamespace(pack), ...)
else checkUsageEnv(as.environment(pname), ...)
}
#++++ check against internal arg count?
primopArgCounts <- mkHash()
anyMissing <- function(args) {
for (i in 1:length(args)) {
a <-args[[i]]
if (missing(a)) return(TRUE) #**** better test?
}
return(FALSE)
}
noMissingAllowed <- c("c")
checkPrimopCall <- function(fn, e, isBuiltin, signal = warning0) {
if (anyMissing(e[-1])) {
if (isBuiltin || fn %in% noMissingAllowed)
signal(paste("missing arguments not allowed in calls to",
sQuote(fn)))
}
if (exists(".GenericArgsEnv") && exists(fn, get(".GenericArgsEnv"))) {
def <- get(fn, envir = get(".GenericArgsEnv"))
checkCall(def, e, signal)
}
else if (exists(".ArgsEnv") && exists(fn, get(".ArgsEnv"))) {
def <- get(fn, envir = get(".ArgsEnv"))
checkCall(def, e, signal)
}
else if (exists(fn, envir = primopArgCounts, inherits = FALSE)) {
argc <- get(fn, envir = primopArgCounts)
if (! any(argc == (length(e) - 1))) {
signal(paste("wrong number of arguments to", sQuote(fn)))
FALSE
}
else TRUE
}
else TRUE
}
local({
zeroArgPrims <- c("break", "browser", "gc.time", "globalenv",
"interactive", "nargs", "next", "proc.time")
for (fn in zeroArgPrims) assign(fn, 0, envir = primopArgCounts)
zeroOrOneArgPrims <- c("invisible")
for (fn in zeroOrOneArgPrims) assign(fn, 0:1, envir = primopArgCounts)
oneArgPrims <- c("!", "(", "abs", "sqrt", "cos", "sin", "tan", "acos",
"asin", "atan", "Re", "Im", "Mod", "Arg", "Conj",
"cosh", "sinh", "tanh", "acosh", "asinh", "atanh",
"sign", "length", "repeat", ".Primitive",
"class", "oldClass", "standardGeneric", "unclass",
"ceiling", "floor", "trunc",
"is.array", "is.atomic", "is.call", "is.character",
"is.complex", "is.double",
"is.environment", "is.expression", "is.finite",
"is.function", "is.infinite", "is.integer",
"is.language", "is.list", "is.loaded", "is.logical",
"is.matrix", "is.na", "is.name", "is.nan", "is.null",
"is.numeric", "is.object", "is.pairlist", "is.real",
"is.recursive", "is.single", "is.symbol",
"debug", "undebug", "as.character", "as.call",
"as.environment", "attributes", "cumsum", "cumprod",
"cummax", "cummin", "dim", "dimnames", "exp", "missing",
"pos.to.env", ".primTrace", ".primUntrace",
"symbol.C", "symbol.For")
for (fn in oneArgPrims) assign(fn, 1, envir = primopArgCounts)
oneOrTwoArgPrims <- c("+", "-")
for (fn in oneOrTwoArgPrims) assign(fn, 1:2, envir = primopArgCounts)
twoArgPrims <- c("*", "/", "%%", "^", "<", "<=", "==", ">", ">=",
"|", "||", ":", "!=", "&", "&&", "%/%", "%*%",
"while", "attr", "attributes<-", "class<-",
"oldClass<-", "dim<-", "dimnames<-", "environment<-",
"length<-", "reg.finalizer")
for (fn in twoArgPrims) assign(fn, 2, envir = primopArgCounts)
assign("on.exit", 0:2, primopArgCounts)
})
matchName <- function(name, list)
if (match(as.character(name), list, 0)) TRUE else FALSE
findVar <- function(e, env) matchName(e, env)
matchCall <- function(def, call, ...) {
## the ... machinations are needed to prevent match.call from signaling
## an error when the call contains a ... argument, and to work with
## versions of match.call that do or do not have the envir argument
## added for R 3.2.0
fun <- function(...)
match.call(def, call, FALSE)
fun()
}
checkCall <- function(def, call, signal = warning0) {
testMatch <- function()
## withCallingHandlers is used to capture partial argument
## matching warnings if enabled.
withCallingHandlers(matchCall(def, call),
warning = function(w) {
msg <- conditionMessage(w)
signal(paste("warning in ",
deparse(call, width.cutoff = 500),
": ", msg, sep=""))
invokeRestart("muffleWarning")
})
msg <- tryCatch({testMatch(); NULL},
error = function(e) conditionMessage(e))
if (! is.null(msg)) {
emsg <- paste("possible error in ", deparse(call, width.cutoff = 500),
": ", msg, sep="")
if (! is.null(signal)) signal(emsg)
FALSE
}
else TRUE
}
##
## Various utilities
##
warning0 <- function(msg) warning(msg, call.=FALSE)
stop0 <- function(msg) stop(msg, call.=FALSE)
pasteExpr <- function(e, prefix = "\n ") {
de <- deparse(e)
if (length(de) == 1) sQuote(de)
else paste(prefix, deparse(e), collapse="")
}
dotsOrMissing <- function(args) {
for (i in 1:length(args)) {
a <-args[[i]]
if (missing(a)) return(TRUE) #**** better test?
if (typeof(a) == "symbol" && a == "...") return(TRUE)
}
return(FALSE)
}
anyDots <- function(args) {
for (i in 1:length(args)) {
a <-args[[i]]
if (! missing(a) && typeof(a) == "symbol" && a == "...")
return(TRUE)
}
return(FALSE)
}
isDDSym <- function(name) {
(is.symbol(name) || is.character(name)) &&
length(grep("^\\.\\.[[:digit:]]+$", as.character(name))) != 0
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.