229 lines
7.8 KiB
R
229 lines
7.8 KiB
R
|
### BREAKPOINTS
|
||
|
.ESSBP. <- new.env()
|
||
|
|
||
|
### DEBUG/UNDEBUG
|
||
|
.ess_find_funcs <- function(env)
|
||
|
{
|
||
|
objs <- ls(envir = env, all.names = TRUE)
|
||
|
objs[sapply(objs, exists, envir = env,
|
||
|
mode = 'function', inherits = FALSE)]
|
||
|
}
|
||
|
|
||
|
.ess_all_functions <- function(packages = c(), env = NULL)
|
||
|
{
|
||
|
if(is.null(env))
|
||
|
env <- parent.frame()
|
||
|
empty <- emptyenv()
|
||
|
coll <- list()
|
||
|
for(p in packages){
|
||
|
## package might not be attached
|
||
|
try(
|
||
|
{
|
||
|
objNS <- .ess_find_funcs(asNamespace(p))
|
||
|
objPKG <- .ess_find_funcs(as.environment(paste0('package:', p)))
|
||
|
objNS <- setdiff(objNS, objPKG)
|
||
|
if(length(objPKG))
|
||
|
coll[[length(coll) + 1]] <- paste0(p, ':::', objNS)
|
||
|
}, silent = TRUE)
|
||
|
}
|
||
|
while(!identical(empty, env)){
|
||
|
coll[[length(coll) + 1]] <- .ess_find_funcs(env)
|
||
|
env <- parent.env(env)
|
||
|
}
|
||
|
grep('^\\.ess', unlist(coll, use.names = FALSE),
|
||
|
invert = TRUE, value = TRUE)
|
||
|
}
|
||
|
|
||
|
.ess_dbg_flag_for_debuging <- function(fname){
|
||
|
all <- utils::getAnywhere(fname)
|
||
|
if(length(all$obj) == 0){
|
||
|
msg <- sprintf("No functions names '%s' found", fname)
|
||
|
} else {
|
||
|
msg <- sprintf("Flagged '%s' for debugging", fname)
|
||
|
tryCatch(lapply(all$obj, debug),
|
||
|
error = function(e){
|
||
|
msg <- paste0("Error: ", e$message)
|
||
|
})
|
||
|
}
|
||
|
cat(msg)
|
||
|
.ess_mpi_message(msg)
|
||
|
}
|
||
|
|
||
|
.ess_dbg_getTracedAndDebugged <- function()
|
||
|
{
|
||
|
packages <- base::.packages()
|
||
|
tr_state <- tracingState(FALSE)
|
||
|
on.exit(tracingState(tr_state))
|
||
|
generics <- methods::getGenerics()
|
||
|
all_traced <- c()
|
||
|
for(i in seq_along(generics)){
|
||
|
genf <- methods::getGeneric(generics[[i]],
|
||
|
package=generics@package[[i]])
|
||
|
if(!is.null(genf)){ ## might happen !! v.2.13
|
||
|
menv <- methods::getMethodsForDispatch(genf)
|
||
|
traced <- unlist(eapply(menv, is, 'traceable', all.names=TRUE))
|
||
|
if(length(traced) && any(traced))
|
||
|
all_traced <- c(paste(generics[[i]],':',
|
||
|
names(traced)[traced],sep=''), all_traced)
|
||
|
tfn <- getFunction(generics[[i]], mustFind=FALSE, where = .GlobalEnv)
|
||
|
if(!is.null(tfn ) && is(tfn, 'traceable')) # if the default is traced, it does not appear in the menv :()
|
||
|
all_traced <- c(generics[[i]], all_traced)
|
||
|
}
|
||
|
}
|
||
|
debugged_pkg <- unlist(lapply(packages, function(pkgname){
|
||
|
ns <- asNamespace(pkgname)
|
||
|
funcs <- .ess_find_funcs(ns)
|
||
|
dbged <- funcs[unlist(lapply(funcs,
|
||
|
function(f){
|
||
|
isdebugged(get(f, envir = ns, inherits = FALSE))
|
||
|
}))]
|
||
|
if(length(dbged))
|
||
|
paste0(pkgname, ':::`', dbged, '`')
|
||
|
}))
|
||
|
env <- parent.frame()
|
||
|
## traced function don't appear here. Not realy needed and would affect performance.
|
||
|
all <- .ess_all_functions(packages = packages, env = env)
|
||
|
which_deb <- lapply(all, function(nm){
|
||
|
## if isdebugged is called with string it doess find
|
||
|
tryCatch(isdebugged(get(nm, envir = env)),
|
||
|
error = function(e) FALSE)
|
||
|
## try(eval(substitute(isdebugged(nm), list(nm = as.name(nm)))), silent = T)
|
||
|
})
|
||
|
debugged <- all[which(unlist(which_deb, recursive=FALSE, use.names=FALSE))]
|
||
|
unique(c(debugged_pkg, debugged, all_traced))
|
||
|
}
|
||
|
|
||
|
.ess_dbg_UntraceOrUndebug <- function(name, env = parent.frame())
|
||
|
{
|
||
|
tr_state <- tracingState(FALSE)
|
||
|
on.exit(tracingState(tr_state))
|
||
|
if( grepl('::', name) ){
|
||
|
## foo:::bar name
|
||
|
eval(parse(text = sprintf('undebug(%s)', name)))
|
||
|
}else{
|
||
|
## name is a name of a function to be undebugged or has a form
|
||
|
## name:Class1#Class2#Class3 for traced methods
|
||
|
name <- strsplit(name, ':', fixed = TRUE)[[1]]
|
||
|
if( length(name)>1 ){
|
||
|
## a method
|
||
|
fun <- name[[1]]
|
||
|
sig <- strsplit(paste(name[-1], collapse=''), '#', fixed=TRUE)[[1]]
|
||
|
untrace(fun, signature = sig)
|
||
|
}else{
|
||
|
## function
|
||
|
if( is(getFunction(name, where = parent.frame()), 'traceable') )
|
||
|
untrace(name)
|
||
|
else if(grepl(":", name))
|
||
|
undebug(name)
|
||
|
else
|
||
|
undebug(get(name, envir = env))
|
||
|
}}
|
||
|
}
|
||
|
|
||
|
.ess_dbg_UndebugALL <- function(funcs)
|
||
|
{
|
||
|
tr_state <- tracingState(FALSE)
|
||
|
on.exit(tracingState(tr_state))
|
||
|
env <- parent.frame()
|
||
|
invisible(lapply(funcs, function( nm ) {
|
||
|
## ugly tryCatch, but there might be several names pointing to the
|
||
|
## same function, like foo:::bar and bar. An alternative would be
|
||
|
## to call .ess_dbg_getTracedAndDebugged each time but that might
|
||
|
## be ery slow
|
||
|
try(.ess_dbg_UntraceOrUndebug(nm, env = env), TRUE)
|
||
|
}))
|
||
|
}
|
||
|
|
||
|
### WATCH
|
||
|
.ess_watch_expressions <- list()
|
||
|
|
||
|
.ess_watch_eval <- function()
|
||
|
{
|
||
|
env <- as.environment("ESSR")
|
||
|
exps <- get('.ess_watch_expressions', envir = env)
|
||
|
if(length(exps) == 0) {
|
||
|
## using old style so this can be parsed by R 1.9.1 (e.g):
|
||
|
cat('\n# Watch list is empty!\n',
|
||
|
'# a append new expression',
|
||
|
'# i insert new expression',
|
||
|
'# k kill',
|
||
|
'# e edit the expression',
|
||
|
'# r rename',
|
||
|
'# n/p navigate',
|
||
|
'# u/d,U move the expression up/down',
|
||
|
'# q kill the buffer',
|
||
|
sep="\n")
|
||
|
} else {
|
||
|
.parent_frame <- parent.frame()
|
||
|
.essWEnames <- allNames(exps)
|
||
|
len0p <- !nzchar(.essWEnames)
|
||
|
.essWEnames[len0p] <- seq_along(len0p)[len0p]
|
||
|
for(i in seq_along(exps)) {
|
||
|
cat('\n@---- ', .essWEnames[[i]], ' ',
|
||
|
rep.int('-', max(0, 35 - nchar(.essWEnames[[i]]))), '-@\n', sep = '')
|
||
|
cat(paste('@---:', deparse(exps[[i]][[1]])), ' \n', sep = '')
|
||
|
tryCatch(print(eval(exps[[i]],
|
||
|
envir = .parent_frame)),
|
||
|
error = function(e) cat('Error:', e$message, '\n' ),
|
||
|
warning = function(w) cat('warning: ', w$message, '\n' ))
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
.ess_watch_assign_expressions <- function(elist){
|
||
|
assign(".ess_watch_expressions", elist, envir = as.environment("ESSR"))
|
||
|
}
|
||
|
|
||
|
.ess_log_eval <- function(log_name)
|
||
|
{
|
||
|
env <- as.environment("ESSR")
|
||
|
if(!exists(log_name, envir = env, inherits = FALSE))
|
||
|
assign(log_name, list(), envir = env)
|
||
|
log <- get(log_name, envir = env, inherits = FALSE)
|
||
|
.essWEnames <- allNames(.ess_watch_expressions)
|
||
|
cur_log <- list()
|
||
|
.parent_frame <- parent.frame()
|
||
|
for(i in seq_along(.ess_watch_expressions)) {
|
||
|
capture.output( {
|
||
|
cur_log[[i]] <-
|
||
|
tryCatch(eval(.ess_watch_expressions[[i]]),
|
||
|
envir = .parent_frame,
|
||
|
error = function(e) paste('Error:', e$message, '\n'),
|
||
|
warning = function(w) paste('warning: ', w$message, '\n'))
|
||
|
if(is.null(cur_log[i][[1]]))
|
||
|
cur_log[i] <- list(NULL)
|
||
|
})
|
||
|
}
|
||
|
names(cur_log) <- .essWEnames
|
||
|
assign(log_name, c(log, list(cur_log)), envir = env)
|
||
|
invisible(NULL)
|
||
|
}
|
||
|
|
||
|
.ess_package_attached <- function(pack_name){
|
||
|
as.logical(match(paste0("package:", pack_name), search()))
|
||
|
}
|
||
|
|
||
|
## magrittr debug_pipe
|
||
|
.ess_pipe_browser <- function(x){
|
||
|
if(is.list(x))
|
||
|
evalq({
|
||
|
browser(skipCalls = 2)
|
||
|
x
|
||
|
}, envir = x)
|
||
|
else if(is.environment(x))
|
||
|
## enclos argumentn has no effect for unclear reason, need to hack
|
||
|
eval(bquote({
|
||
|
x <- .(environment())
|
||
|
browser(skipCalls = 2)
|
||
|
x
|
||
|
}), envir = x)
|
||
|
else {
|
||
|
browser(skipCalls = 0)
|
||
|
x
|
||
|
}
|
||
|
}
|
||
|
|
||
|
## Local Variables:
|
||
|
## eval: (ess-set-style 'RRR t)
|
||
|
## End:
|