« back to all changes in this revision
Viewing changes to etc/ESSR.R
- browse files at revision 38
- compare with another revision
- download diff
- download tarball
- view history from revision 38
- Committer: Package Import Robot
- Author(s): Dirk Eddelbuettel
- Date: 2013-12-07 13:26:27 UTC
- mfrom: (1.2.32)
- Revision ID: package-import@ubuntu.com-20131207132627-3x438vgvdg21763i
Tags: 13.09-1-1
* New upstream version released today
* debian/control: Increased Standards-Version: to current version
* debian/control: Increased Standards-Version: to current version
- files added:
- doc/installation.texi
- etc/ESSR
- etc/ESSR/R
- etc/ESSR/man
- etc/library
- files removed:
- doc/unixlike.texi
- 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) ## also works for special objects containing @:$ etc
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('\"', '\\\"',
52
gsub("\\", "\\\\", as.character(fmls),fixed = TRUE),
53
fixed=TRUE)
54
args_alist <-
55
sprintf("'(%s)",
56
paste("(\"", fmls_names, "\" . \"", fmls, "\")",
57
sep = '', collapse = ' '))
58
allargs <-
59
if(special) fmls_names
60
else tryCatch(gsub('=', '', utils:::functionArgs(funname, ''), fixed = TRUE),
61
error=function(e) NULL)
62
allargs <- sprintf("'(\"%s\")",
63
paste(allargs, collapse = '\" "'))
64
envname <- environmentName(environment(fun))
65
if(envname == "R_GlobalEnv") envname <- ""
66
cat(sprintf('(list \"%s\" %s %s)\n',
67
envname, args_alist, allargs))
68
}
69
}
70
71
.ess_get_completions <- function(string, end){
72
if(getRversion() > '2.14.1'){
73
comp <- compiler::enableJIT(0L)
74
olderr <- getOption('error')
75
options(error=NULL)
76
on.exit({options(error = olderr)
77
compiler::enableJIT(comp)})
78
}
79
utils:::.assignLinebuffer(string)
80
utils:::.assignEnd(end)
81
utils:::.guessTokenFromLine()
82
utils:::.completeToken()
83
c(get('token', envir=utils:::.CompletionEnv),
84
utils:::.retrieveCompletions())
85
}
86
87
### SOURCING
88
89
.ess_eval <- function(string, echo = TRUE, print.eval = TRUE, max.deparse.length = 300,
90
file = tempfile("ESS"), local = parent.frame()){
91
cat(string, file = file)
92
.ess_source(file, echo = echo, print.eval = print.eval,
93
max.deparse.length = max.deparse.length, local = local)
94
}
95
96
.ess_source <- function(file, echo = TRUE, print.eval = TRUE,
97
max.deparse.length = 300, local = parent.frame()){
98
invisible(base::source(file = file,
99
echo = echo, local = local,
100
print.eval = print.eval,
101
max.deparse.length = 300,
102
keep.source = TRUE)$value) ## return value for org-babel
103
}
104
105
### WEAVING
106
.ess_weave <- function(command, file, encoding = NULL){
107
if(grepl('knit|purl', deparse(substitute(command))))
108
require(knitr)
109
od <- getwd()
110
on.exit(setwd(od))
111
setwd(dirname(file))
112
if(is.null(encoding))
113
command(file)
114
else
115
command(file, encoding = encoding)
116
}
117
118
### BREAKPOINTS
119
.ESSBP. <- list()
120
121
### DEBUG/UNDEBUG
122
.ess_find_funcs <- function(env)
123
{
124
objs <- ls(envir = env, all.names = TRUE)
125
objs[sapply(objs, exists, envir = env,
126
mode = 'function', inherits = FALSE)]
127
}
128
129
.ess_all_functions <- function(packages = c(), env = NULL)
130
{
131
if(is.null(env))
132
env <- parent.frame()
133
empty <- emptyenv()
134
coll <- list()
135
for(p in packages){
136
## package might not be attached
137
try({objNS <- .ess_find_funcs(asNamespace(p))
138
objPKG <- .ess_find_funcs(as.environment(paste0('package:', p)))
139
coll[[length(coll) + 1L]] <-
140
paste0(p, ':::`', setdiff(objNS, objPKG), '`')
141
}, silent = TRUE)
142
}
143
while(!identical(empty, env)){
144
coll[[length(coll) + 1L]] <- .ess_find_funcs(env)
145
env <- parent.env(env)
146
}
147
grep('^\\.ess', unlist(coll, use.names = FALSE),
148
invert = TRUE, value = TRUE)
149
}
150
151
.ess_dbg_getTracedAndDebugged <- function(packages = c())
152
{
153
tr_state <- tracingState(FALSE)
154
on.exit(tracingState(tr_state))
155
generics <- methods::getGenerics()
156
all_traced <- c()
157
for(i in seq_along(generics)){
158
genf <- methods::getGeneric(generics[[i]],
159
package=generics@package[[i]])
160
if(!is.null(genf)){ ## might happen !! v.2.13
161
menv <- methods::getMethodsForDispatch(genf)
162
traced <- unlist(eapply(menv, is, 'traceable', all.names=TRUE))
163
if(length(traced) && any(traced))
164
all_traced <- c(paste(generics[[i]],':',
165
names(traced)[traced],sep=''), all_traced)
166
tfn <- getFunction(generics[[i]], mustFind=FALSE, where = .GlobalEnv)
167
if(!is.null(tfn ) && is(tfn, 'traceable')) # if the default is traced, it does not appear in the menv :()
168
all_traced <- c(generics[[i]], all_traced)
169
}
170
}
171
debugged_pkg <- unlist(lapply(packages, function(pkgname){
172
ns <- asNamespace(pkgname)
173
funcs <- .ess_find_funcs(ns)
174
dbged <- funcs[unlist(lapply(funcs,
175
function(f){
176
isdebugged(get(f, envir = ns, inherits = FALSE))
177
}))]
178
if(length(dbged))
179
paste0(pkgname, ':::`', dbged, '`')
180
}))
181
env <- parent.frame()
182
## traced function don't appear here. Not realy needed and would affect performance.
183
all <- .ess_all_functions(packages = packages, env = env)
184
which_deb <- lapply(all, function(nm){
185
## if isdebugged is called with string it doess find
186
tryCatch(isdebugged(get(nm, envir = env)),
187
error = function(e) FALSE)
188
## try(eval(substitute(isdebugged(nm), list(nm = as.name(nm)))), silent = T)
189
})
190
debugged <- all[which(unlist(which_deb, recursive=FALSE, use.names=FALSE))]
191
unique(c(debugged_pkg, debugged, all_traced))
192
}
193
194
.ess_dbg_UntraceOrUndebug <- function(name, env = parent.frame())
195
{
196
tr_state <- tracingState(FALSE)
197
on.exit(tracingState(tr_state))
198
if( grepl('::', name) ){
199
## foo:::bar name
200
eval(parse(text = sprintf('undebug(%s)', name)))
201
}else{
202
## name is a name of a function to be undebugged or has a form
203
## name:Class1#Class2#Class3 for traced methods
204
name <- strsplit(name, ':', fixed = TRUE)[[1]]
205
if( length(name)>1 ){
206
## a method
207
fun <- name[[1]]
208
sig <- strsplit(paste(name[-1], collapse=''), '#', fixed=TRUE)[[1]]
209
untrace(fun, signature = sig)
210
}else{
211
## function
212
if( is(getFunction(name, where = parent.frame()), 'traceable') )
213
untrace(name)
214
else if(grepl(":", name))
215
undebug(name)
216
else
217
undebug(get(name, envir = env))
218
}}
219
}
220
221
.ess_dbg_UndebugALL <- function(funcs)
222
{
223
tr_state <- tracingState(FALSE)
224
on.exit(tracingState(tr_state))
225
env <- parent.frame()
226
invisible(lapply(funcs, function( nm ) {
227
## ugly tryCatch, but there might be several names pointing to the
228
## same function, like foo:::bar and bar. An alternative would be
229
## to call .ess_dbg_getTracedAndDebugged each time but that might
230
## be ery slow
231
try(.ess_dbg_UntraceOrUndebug(nm, env = env), TRUE)
232
}))
233
}
234
235
### WATCH
236
.ess_watch_expressions <- list()
237
238
.ess_watch_eval <- function()
239
{
240
if(!exists('.ess_watch_expressions')) {
241
assign('.ess_watch_expressions', list(), envir = .GlobalEnv)
242
}
243
if(length(.ess_watch_expressions) == 0L) {
244
cat('\n# Watch list is empty!\n
245
# a append new expression
246
# i insert new expression
247
# k kill
248
# e edit the expression
249
# r rename
250
# n/p navigate
251
# u/d,U move the expression up/down
252
# q kill the buffer
253
')
254
} else {
255
.parent_frame <- parent.frame()
256
.essWEnames <- allNames(.ess_watch_expressions)
257
len0p <- !nzchar(.essWEnames)
258
.essWEnames[len0p] <- seq_along(len0p)[len0p]
259
for(i in seq_along(.ess_watch_expressions)) {
260
cat('\n@---- ', .essWEnames[[i]], ' ',
261
rep.int('-', max(0, 35 - nchar(.essWEnames[[i]]))), '-@\n', sep = '')
262
cat(paste('@---:', deparse(.ess_watch_expressions[[i]][[1L]])), ' \n', sep = '')
263
tryCatch(print(eval(.ess_watch_expressions[[i]],
264
envir = .parent_frame)),
265
error = function(e) cat('Error:', e$message, '\n' ),
266
warning = function(w) cat('warning: ', w$message, '\n' ))
267
}
268
}
269
}
270
271
.ess_log_eval <- function(log_name)
272
{
273
if(!exists(log_name, envir = .GlobalEnv, inherits = FALSE))
274
assign(log_name, list(), envir = .GlobalEnv)
275
log <- get(log_name, envir = .GlobalEnv, inherits = FALSE)
276
.essWEnames <- allNames(.ess_watch_expressions)
277
cur_log <- list()
278
.parent_frame <- parent.frame()
279
for(i in seq_along(.ess_watch_expressions)) {
280
capture.output( {
281
cur_log[[i]] <-
282
tryCatch(eval(.ess_watch_expressions[[i]]),
283
envir = .parent_frame,
284
error = function(e) paste('Error:', e$message, '\n'),
285
warning = function(w) paste('warning: ', w$message, '\n'))
286
if(is.null(cur_log[i][[1]]))
287
cur_log[i] <- list(NULL)
288
})
289
}
290
names(cur_log) <- .essWEnames
291
assign(log_name, c(log, list(cur_log)), envir = .GlobalEnv)
292
invisible(NULL)
293
}
294
295
.ess_package_attached <- function(pack_name){
296
as.logical(match(paste0("package:", pack_name), search()))
297
}
298
})}
299
300
## length(ls(.ESSR_Env, all = TRUE)) # VS[01-05-2013]: 13 functs
Loggerhead is a web-based interface for Breezy
Version: 2.0.1