« back to all changes in this revision
Viewing changes to etc/ESSR.R
- browse files at revision 34
- compare with another revision
- download diff
- download tarball
- view history from revision 34
- Committer: Package Import Robot
- Author(s): Dirk Eddelbuettel
- Date: 2013-05-15 06:31:40 UTC
- mfrom: (1.2.30)
- Revision ID: package-import@ubuntu.com-20130515063140-ewn6t06oo3bqthou
Tags: 13.05-1
New upstream version released today
- files added:
- doc/ess-manual.org
- files modified:
- ChangeLog
added
removed
etc/ESSR.R
1
{if ("ESSR" %in% search()) detach("ESSR") # good for debugging ESSR
2
ESSR <- attach(NULL, pos = 5, name = "ESSR", warn.conflicts = FALSE)
3
ESSR$.ESSR_Env <- ESSR
4
ESSR$.ess_evalq <- function(expr){
5
## like evalq but change the enclosure
6
.Internal(eval(substitute(expr), .ESSR_Env, baseenv()))
7
invisible(lapply(.ESSR_Env$.ess_find_funcs(.ESSR_Env),
8
function(fun){
9
environment(.ESSR_Env[[fun]]) <- .BaseNamespaceEnv
10
}))
11
}
12
remove(ESSR)
13
14
.ess_evalq({
15
16
### BASICS
17
.ess_help <- function(..., help_type = getOption('help_type')){
18
if (getRversion() > '2.10')
19
utils::help(..., help_type = help_type)
20
else
21
utils::help(..., htmlhelp = (help_type=='html'))
22
}
23
24
.ess_funargs <- function(funname){
25
if(getRversion() > '2.14.1'){
26
comp <- compiler::enableJIT(0L)
27
olderr <- getOption('error')
28
options(error=NULL)
29
on.exit({
30
compiler::enableJIT(comp)
31
options(error = olderr)
32
})
33
}
34
## don't remove; really need eval(parse( here!!
35
fun <- tryCatch(eval(parse(text=funname)),
36
error=function(e) NULL) ## works for special objects also
37
if(is.function(fun)) {
38
special <- grepl('[:$@[]', funname)
39
args <- if(!special){
40
fundef <- paste(funname, '.default',sep='')
41
do.call('argsAnywhere', list(fundef))
42
}
43
44
if(is.null(args))
45
args <- args(fun)
46
if(is.null(args))
47
args <- do.call('argsAnywhere', list(funname))
48
49
fmls <- formals(args)
50
fmls_names <- names(fmls)
51
fmls <- gsub('\"', '\\\"', as.character(fmls), fixed=TRUE)
52
args_alist <-
53
sprintf("'(%s)",
54
paste("(\"", fmls_names, "\" . \"", fmls, "\")",
55
sep = '', collapse = ' '))
56
allargs <-
57
if(special) fmls_names
58
else tryCatch(gsub('=', '', utils:::functionArgs(funname, ''), fixed = TRUE),
59
error=function(e) NULL)
60
allargs <- sprintf("'(\"%s\")",
61
paste(allargs, collapse = '\" "'))
62
envname <- environmentName(environment(fun))
63
cat(sprintf('(list \"%s\" %s %s)\n',
64
envname, args_alist, allargs))
65
}
66
}
67
68
.ess_get_completions <- function(string, end){
69
if(getRversion() > '2.14.1'){
70
comp <- compiler::enableJIT(0L)
71
olderr <- getOption('error')
72
options(error=NULL)
73
on.exit({options(error = olderr)
74
compiler::enableJIT(comp)})
75
}
76
utils:::.assignLinebuffer(string)
77
utils:::.assignEnd(end)
78
utils:::.guessTokenFromLine()
79
utils:::.completeToken()
80
c(get('token', envir=utils:::.CompletionEnv),
81
utils:::.retrieveCompletions())
82
}
83
84
### WEAVING
85
.ess_weave <- function(command, file, encoding = NULL){
86
if(grepl('knit|purl', deparse(substitute(command))))
87
require(knitr)
88
od <- getwd()
89
on.exit(setwd(od))
90
setwd(dirname(file))
91
if(is.null(encoding))
92
command(file)
93
else
94
command(file, encoding = encoding)
95
}
96
97
98
### DEBUG/UNDEBUG
99
.ess_find_funcs <- function(env)
100
{
101
objs <- ls(envir = env, all.names = TRUE)
102
objs[sapply(objs, exists, envir = env,
103
mode = 'function', inherits = FALSE)]
104
}
105
106
.ess_all_functions <- function(packages = c(), env = NULL)
107
{
108
if(is.null(env))
109
env <- parent.frame()
110
empty <- emptyenv()
111
coll <- list()
112
for(p in packages){
113
## package might not be attached
114
try({objNS <- .ess_find_funcs(asNamespace(p))
115
objPKG <- .ess_find_funcs(as.environment(paste0('package:', p)))
116
coll[[length(coll) + 1L]] <-
117
paste0(p, ':::`', setdiff(objNS, objPKG), '`')
118
}, silent = TRUE)
119
}
120
while(!identical(empty, env)){
121
coll[[length(coll) + 1L]] <- .ess_find_funcs(env)
122
env <- parent.env(env)
123
}
124
grep('^\\.ess', unlist(coll, use.names = FALSE),
125
invert = TRUE, value = TRUE)
126
}
127
128
.ess_dbg_getTracedAndDebugged <- function(packages = c())
129
{
130
tr_state <- tracingState(FALSE)
131
on.exit(tracingState(tr_state))
132
generics <- methods::getGenerics()
133
all_traced <- c()
134
for(i in seq_along(generics)){
135
genf <- methods::getGeneric(generics[[i]],
136
package=generics@package[[i]])
137
if(!is.null(genf)){ ## might happen !! v.2.13
138
menv <- methods::getMethodsForDispatch(genf)
139
traced <- unlist(eapply(menv, is, 'traceable', all.names=TRUE))
140
if(length(traced) && any(traced))
141
all_traced <- c(paste(generics[[i]],':',
142
names(traced)[traced],sep=''), all_traced)
143
tfn <- getFunction(generics[[i]], mustFind=FALSE, where = .GlobalEnv)
144
if(!is.null(tfn ) && is(tfn, 'traceable')) # if the default is traced, it does not appear in the menv :()
145
all_traced <- c(generics[[i]], all_traced)
146
}
147
}
148
debugged_pkg <- unlist(lapply(packages, function(pkgname){
149
ns <- asNamespace(pkgname)
150
funcs <- .ess_find_funcs(ns)
151
dbged <- funcs[unlist(lapply(funcs,
152
function(f){
153
isdebugged(get(f, envir = ns, inherits = FALSE))
154
}))]
155
if(length(dbged))
156
paste0(pkgname, ':::`', dbged, '`')
157
}))
158
env <- parent.frame()
159
## traced function don't appear here. Not realy needed and would affect performance.
160
all <- .ess_all_functions(packages = packages, env = env)
161
which_deb <- lapply(all, function(nm){
162
## if isdebugged is called with string it doess find
163
tryCatch(isdebugged(get(nm, envir = env)),
164
error = function(e) FALSE)
165
## try(eval(substitute(isdebugged(nm), list(nm = as.name(nm)))), silent = T)
166
})
167
debugged <- all[which(unlist(which_deb, recursive=FALSE, use.names=FALSE))]
168
unique(c(debugged_pkg, debugged, all_traced))
169
}
170
171
.ess_dbg_UntraceOrUndebug <- function(name, env = parent.frame())
172
{
173
tr_state <- tracingState(FALSE)
174
on.exit(tracingState(tr_state))
175
if( grepl('::', name) ){
176
## foo:::bar name
177
eval(parse(text = sprintf('undebug(%s)', name)))
178
}else{
179
## name is a name of a function to be undebugged or has a form
180
## name:Class1#Class2#Class3 for traced methods
181
name <- strsplit(name, ':', fixed = TRUE)[[1]]
182
if( length(name)>1 ){
183
## a method
184
fun <- name[[1]]
185
sig <- strsplit(paste(name[-1], collapse=''), '#', fixed=TRUE)[[1]]
186
untrace(fun, signature = sig)
187
}else{
188
## function
189
if( is(getFunction(name, where = parent.frame()), 'traceable') )
190
untrace(name)
191
else if(grepl(":", name))
192
undebug(name)
193
else
194
undebug(get(name, envir = env))
195
}}}
196
197
.ess_dbg_UndebugALL <- function(funcs)
198
{
199
tr_state <- tracingState(FALSE)
200
on.exit(tracingState(tr_state))
201
env <- parent.frame()
202
invisible(lapply(funcs, function( nm ){
203
## ugly tryCatch, but there might be several names pointing to the
204
## same function, like foo:::bar and bar. An alternative would be
205
## to call .ess_dbg_getTracedAndDebugged each time but that might
206
## be ery slow
207
try(.ess_dbg_UntraceOrUndebug(nm, env = env), TRUE)
208
}))
209
}
210
211
### WATCH
212
.ess_watch_expressions <- list()
213
214
.ess_watch_eval <- function()
215
{
216
if(!exists('.ess_watch_expressions')){
217
assign('.ess_watch_expressions', list(), envir = .GlobalEnv)
218
}
219
if(length(.ess_watch_expressions) == 0L){
220
cat('\n# Watch list is empty!\n
221
# a append new expression
222
# i insert new expression
223
# k kill
224
# e edit the expression
225
# r rename
226
# n/p navigate
227
# u/d,U move the expression up/down
228
# q kill the buffer
229
')
230
}else{
231
.parent_frame <- parent.frame()
232
.essWEnames <- allNames(.ess_watch_expressions)
233
len0p <- !nzchar(.essWEnames)
234
.essWEnames[len0p] <- seq_along(len0p)[len0p]
235
for(i in seq_along(.ess_watch_expressions)){
236
cat('\n@---- ', .essWEnames[[i]], ' ',
237
rep.int('-', max(0, 35 - nchar(.essWEnames[[i]]))), '-@\n', sep = '')
238
cat(paste('@---:', deparse(.ess_watch_expressions[[i]][[1L]])), ' \n', sep = '')
239
tryCatch(print(eval(.ess_watch_expressions[[i]],
240
envir = .parent_frame)),
241
error = function(e) cat('Error:', e$message, '\n' ),
242
warning = function(w) cat('warning: ', w$message, '\n' ))
243
}}
244
}
245
246
.ess_log_eval <- function(log_name)
247
{
248
if(!exists(log_name, envir = .GlobalEnv, inherits = FALSE))
249
assign(log_name, list(), envir = .GlobalEnv)
250
log <- get(log_name, envir = .GlobalEnv, inherits = FALSE)
251
.essWEnames <- allNames(.ess_watch_expressions)
252
cur_log <- list()
253
.parent_frame <- parent.frame()
254
for(i in seq_along(.ess_watch_expressions)){
255
capture.output({
256
cur_log[[i]] <-
257
tryCatch(eval(.ess_watch_expressions[[i]]),
258
envir = .parent_frame,
259
error = function(e) paste('Error:', e$message, '\n'),
260
warning = function(w) paste('warning: ', w$message, '\n'))
261
if(is.null(cur_log[i][[1]]))
262
cur_log[i] <- list(NULL)
263
})
264
}
265
names(cur_log) <- .essWEnames
266
assign(log_name, c(log, list(cur_log)), envir = .GlobalEnv)
267
invisible(NULL)
268
}
269
})}
270
271
## length(ls(.ESSR_Env, all = TRUE)) # VS[01-05-2013]: 13 functs
Loggerhead is a web-based interface for Breezy
Version: 2.0.1