1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
# printcall.R: functions for printing call information
# If call is specified, print it (where call is from match.call or similar).
# Else use the call stack to determine the call. The n arg tells us how
# far to go back in the call stack.
#
# Examples: printcall() describe the call to the current function
# printcall(n=2) describe the call to the caller of the current function
# printcall(call) describe call where call is from match.call or similar
printcall <- function(prefix="", call=NULL, all=FALSE, n=1)
{
# check prefix and n here, other args checked in call.as.char
stopifnot.string(prefix, allow.empty=TRUE)
stopifnot(is.numeric(n))
call <- call.as.char(call, all, n+1)
printf.wrap("%s%s\n", prefix, call)
}
# returns args and concise description of their values, dots are included
# all=TRUE to include all formal args (not always avail e.g. for primitives)
#
# TODO Does not expand the dots (just prints "..."), need fixed version of match.call
# to expand the dots see e.g. higher.call.to.deprefix (but that would only work
# here if dots for caller at n where the same as the dots to printcall).
call.as.char <- function(call=NULL, all=FALSE, n=1)
{
stopifnot(is.numeric(all) || is.logical(all), length(all) == 1)
stopifnot(is.numeric(n), length(n) == 1, n > 0)
if(is.null(call))
call <- match.call2(all=all, n=n+1) # +1 to skip call to call.as.char
else if(all) # we have the call but not the func itself, so can't get formals
stop("all=TRUE is not allowed when the call argument is used")
fname <- fname.from.call(call)
if(all) {
formals <- formals(attr(call, "sys.function"))
call[[1]] <- NULL # delete func name from call, leave args
formals[["..."]] <- NULL # delete ... in formal args if any
call <- merge.list(formals, call)
} else
call[[1]] <- NULL # delete func name from call, leave args
ret <- paste(fname, "(", list.as.char(call, maxlen=50), ")", sep="")
attr(ret, "fname") <- fname # needed for alignment with nchar in printcall
ret
}
# Similar to match.call but with args "all" and "n".
# Also, this always returns a call, even if it is merely "unknown()".
# So you can safely call it with any n (although n must be a positive int).
match.call2 <- function(all=FALSE, n=1)
{
stopifnot(is.numeric(all) || is.logical(all), length(all) == 1)
stopifnot(is.numeric(n), length(n) == 1, n > 0)
# get sys.function and sys.call for the given n, needed for match.call
sys.function <- try(sys.function(-n), silent=TRUE)
if(is.try.err(sys.function) || is.null(sys.function)) # typically "not that many frames"
return(call("unknown"))
sys.call <- try(sys.call(-n), silent=TRUE)
if(is.try.err(sys.call) || is.null(sys.call))
return(call("unknown"))
# TODO following can cause incorrect "... used in a situation where it does not exist"
# R version 3.1.4 will fix that issue in match.call (I hope)
# envir <- parent.frame(n+1) # use when new version of match.call is ready
call <- try(match.call(definition=sys.function, call=sys.call, expand.dots=TRUE),
silent=TRUE)
if(is.try.err(call)) {
# match.call failed, fallback to a weaker description of call
# no expansion of dots and no arg values :(
call <- sys.call
}
attr(call, "sys.function") <- sys.function
call
}
callers.name <- function(n=1)
{
stopifnot(is.numeric(n), length(n) == 1, floor(n) == n, n >= 0)
call <- try(sys.call(-(n+1)), silent=TRUE)
fname.from.call(call) # will also check if try error
}
fname.from.call <- function(call) # call was obtained using sys.call() or similar
{
if(is.try.err(call))
return("unknown") # most likely n was misspecified (too big)
if(is.null(call)) # e.g. NULL->source->withVisible->eval->eval->print->test->callers.name
return("NULL")
caller <- as.list(call)[[1]]
if(is.name(caller)) # e.g. foo3(x=1)
caller <- as.character(caller)
else { # class(caller) is "call" e.g. plotmo::localfunc(x=1)
stopifnot(is.call(call))
caller <- format(caller)
}
if(grepl("function (", substr(caller[1], 1, 10), fixed=TRUE))
paste0("function(", paste.trunc(strip.space.collapse(substring(caller, 11))), ")")
else
paste.trunc(strip.space.collapse(caller))
}
# if EVAL is FALSE this will print something like xlim=..1, ylim=..2
# TODO add n arg when match.call is fixed (R version 3.2.1)
# TODO also then make this callable as printdots() instead of printdots(...)
printdots <- function(..., EVAL=TRUE, PREFIX=sprint("%s dots: ", callers.name))
{
sys.call <- as.list(sys.call())
ensure.dots.present(sys.call)
callers.name <- callers.name()
printf.wrap("%s%s\n", PREFIX, dots.as.char(..., EVAL=EVAL))
}
dots.as.char <- function(..., EVAL=TRUE)
{
sys.call <- as.list(sys.call())
ensure.dots.present(sys.call)
dots <- match.call(expand.dots=FALSE)$...
if(is.null(dots))
return("no dots")
if(EVAL) {
stopifnot(is.numeric(EVAL) || is.logical(EVAL), length(EVAL) == 1)
dots <- eval.dotlist(dots)
}
list.as.char(dots)
}
# issue error message if ... wasn't used in the call to dots.as.char
ensure.dots.present <- function(sys.call)
{
dots.present <- FALSE
for(i in seq_len(length(sys.call)))
if(sys.call[i] == "...")
dots.present <- TRUE
if(!dots.present)
stop0("dots.as.char should be invoked with dots, for example dots.as.char(...)")
}
|
