R trace()是一个功能强大的调试工具,允许用户"在任何函数中的选定位置插入调试代码".不幸的是,从命令行使用它可能相当费力.
作为一个人为的例子,假设我想插入调试代码,该代码将报告计算的间隔时间间隔pretty.default().我想在delta计算值后立即插入代码,从函数定义的底部开始大约四行.(键入pretty.default以查看我的意思.)要指示该行,我需要找到它对应的代码中的哪一步.答案结果是步骤list(c(12, 3, 3)),我通过执行以下步骤来实现这一点:
as.list(body(pretty.default))
as.list(as.list(body(pretty.default))[[12]])
as.list(as.list(as.list(body(pretty.default))[[12]])[[3]])
as.list(as.list(as.list(body(pretty.default))[[12]])[[3]])[[3]]
然后我可以插入这样的调试代码:
trace(what = 'pretty.default',
tracer = quote(cat("\nThe value of delta is: ", delta, "\n\n")),
at = list(c(12,3,3)))
## Try it
a <- pretty(c(1, 7843))
b <- pretty(c(2, 23))
## Clean up
untrace('pretty.default')
所以这里有我的问题:有没有办法打印出一个函数(或它的解析版本),其中的行被它们所属的步骤很好地标记了？(根据Venables和Ripley的说法,S-plus有一个函数tprint()"产生一个函数体的编号列表,用于at参数trace",但R似乎没有等价物.)或者,还有另一种更简单的方法,从命令行,快速设置函数内特定行的调试代码？
我使用这个pretty.default()例子是因为它有合理的驯服,但是有了真实/有趣的功能,反复使用as.list()很快会变得烦人和分散注意力.这是一个例子:
as.list(as.list(as.list(as.list(as.list(as.list(as.list(as.list(as.list(body(#
model.frame.default))[[26]])[[3]])[[2]])[[4]])[[3]])[[4]])[[4]])[[4]])[[3]]
这里的东西是非常有效的pretty.default和model.frame.default.
print.func <- function(func, ...) {
str(as.list.func(func, ...), comp.str="")
}
as.list.func <- function(func, recurse.keywords = c("{", "if", "repeat", "while", "for", "switch")) {
as.list.func.recurse(body(func), recurse.keywords)
}
as.list.func.recurse <- function(x, recurse.keywords) {
x.list <- as.list(x)
top <- deparse(x.list[[1]])
if (length(x.list) > 1 && top %in% recurse.keywords) {
res <- lapply(x.list, as.list.func.recurse, recurse.keywords)
setNames(res, seq_along(res))
} else {
x
}
}
结果pretty.default:
> print.func(pretty.default)
List of 13
1 : symbol {
2 : language x <- x[is.finite(x <- as.numeric(x))]
3 :List of 3
..$ 1: symbol if
..$ 2: language length(x) == 0L
..$ 3: language return(x)
4 :List of 3
..$ 1: symbol if
..$ 2: language is.na(n <- as.integer(n[1L])) || n < 0L
..$ 3: language stop("invalid 'n' value")
5 :List of 3
..$ 1: symbol if
..$ 2: language !is.numeric(shrink.sml) || shrink.sml <= 0
..$ 3: language stop("'shrink.sml' must be numeric > 0")
6 :List of 3
..$ 1: symbol if
..$ 2: language (min.n <- as.integer(min.n)) < 0 || min.n > n
..$ 3: language stop("'min.n' must be non-negative integer <= n")
7 :List of 3
..$ 1: symbol if
..$ 2: language !is.numeric(high.u.bias) || high.u.bias < 0
..$ 3: language stop("'high.u.bias' must be non-negative numeric")
8 :List of 3
..$ 1: symbol if
..$ 2: language !is.numeric(u5.bias) || u5.bias < 0
..$ 3: language stop("'u5.bias' must be non-negative numeric")
9 :List of 3
..$ 1: symbol if
..$ 2: language (eps.correct <- as.integer(eps.correct)) < 0L || eps.correct > 2L
..$ 3: language stop("'eps.correct' must be 0, 1, or 2")
10: language z <- .C("R_pretty", l = as.double(min(x)), u = as.double(max(x)), n = n, min.n, shrink = as.double(shrink.sml), high.u.fact = as.double(c(high.u.bias, ...
11: language s <- seq.int(z$l, z$u, length.out = z$n + 1)
12:List of 3
..$ 1: symbol if
..$ 2: language !eps.correct && z$n
..$ 3:List of 3
.. ..$ 1: symbol {
.. ..$ 2: language delta <- diff(range(z$l, z$u))/z$n
.. ..$ 3:List of 3
.. .. ..$ 1: symbol if
.. .. ..$ 2: language any(small <- abs(s) < 1e-14 * delta)
.. .. ..$ 3: language s[small] <- 0
13: symbol s
结果model.frame.default:
> print.func(model.frame.default)
List of 29
1 : symbol {
2 : language possible_newdata <- !missing(data) && is.data.frame(data) && identical(deparse(substitute(data)), "newdata") && (nr <- nrow(data)) > 0
3 :List of 3
..$ 1: symbol if
..$ 2: language !missing(formula) && nargs() == 1 && is.list(formula) && !is.null(m <- formula$model)
..$ 3: language return(m)
4 :List of 3
..$ 1: symbol if
..$ 2: language !missing(formula) && nargs() == 1 && is.list(formula) && all(c("terms", "call") %in% names(formula))
..$ 3:List of 8
.. ..$ 1: symbol {
.. ..$ 2: language fcall <- formula$call
.. ..$ 3: language m <- match(c("formula", "data", "subset", "weights", "na.action"), names(fcall), 0)
.. ..$ 4: language fcall <- fcall[c(1, m)]
.. ..$ 5: language fcall[[1L]] <- as.name("model.frame")
.. ..$ 6: language env <- environment(formula$terms)
.. ..$ 7:List of 3
.. .. ..$ 1: symbol if
.. .. ..$ 2: language is.null(env)
.. .. ..$ 3: language env <- parent.frame()
.. ..$ 8: language return(eval(fcall, env, parent.frame()))
5 :List of 4
..$ 1: symbol if
..$ 2: language missing(formula)
..$ 3:List of 3
.. ..$ 1: symbol {
.. ..$ 2:List of 3
.. .. ..$ 1: symbol if
.. .. ..$ 2: language !missing(data) && inherits(data, "data.frame") && length(attr(data, "terms"))
.. .. ..$ 3: language return(data)
.. ..$ 3: language formula <- as.formula(data)
..$ 4:List of 3
.. ..$ 1: symbol if
.. ..$ 2: language missing(data) && inherits(formula, "data.frame")
.. ..$ 3:List of 4
.. .. ..$ 1: symbol {
.. .. ..$ 2:List of 3
.. .. .. ..$ 1: symbol if
.. .. .. ..$ 2: language length(attr(formula, "terms"))
.. .. .. ..$ 3: language return(formula)
.. .. ..$ 3: language data <- formula
.. .. ..$ 4: language formula <- as.formula(data)
6 : language formula <- as.formula(formula)
7 :List of 3
..$ 1: symbol if
..$ 2: language missing(na.action)
..$ 3:List of 2
.. ..$ 1: symbol {
.. ..$ 2:List of 4
.. .. ..$ 1: symbol if
.. .. ..$ 2: language !is.null(naa <- attr(data, "na.action")) & mode(naa) != "numeric"
.. .. ..$ 3: language na.action <- naa
.. .. ..$ 4:List of 3
.. .. .. ..$ 1: symbol if
.. .. .. ..$ 2: language !is.null(naa <- getOption("na.action"))
.. .. .. ..$ 3: language na.action <- naa
8 :List of 4
..$ 1: symbol if
..$ 2: language missing(data)
..$ 3: language data <- environment(formula)
..$ 4:List of 4
.. ..$ 1: symbol if
.. ..$ 2: language !is.data.frame(data) && !is.environment(data) && !is.null(attr(data, "class"))
.. ..$ 3: language data <- as.data.frame(data)
.. ..$ 4:List of 3
.. .. ..$ 1: symbol if
.. .. ..$ 2: language is.array(data)
.. .. ..$ 3: language stop("'data' must be a data.frame, not a matrix or an array")
9 :List of 3
..$ 1: symbol if
..$ 2: language !inherits(formula, "terms")
..$ 3: language formula <- terms(formula, data = data)
10: language env <- environment(formula)
11: language rownames <- .row_names_info(data, 0L)
12: language vars <- attr(formula, "variables")
13: language predvars <- attr(formula, "predvars")
14:List of 3
..$ 1: symbol if
..$ 2: language is.null(predvars)
..$ 3: language predvars <- vars
15: language varnames <- sapply(vars, function(x) paste(deparse(x, width.cutoff = 500), collapse = " "))[-1L]
16: language variables <- eval(predvars, data, env)
17: language resp <- attr(formula, "response")
18:List of 3
..$ 1: symbol if
..$ 2: language is.null(rownames) && resp > 0L
..$ 3:List of 3
.. ..$ 1: symbol {
.. ..$ 2: language lhs <- variables[[resp]]
.. ..$ 3: language rownames <- if (is.matrix(lhs)) rownames(lhs) else names(lhs)
19:List of 3
..$ 1: symbol if
..$ 2: language possible_newdata && length(variables)
..$ 3:List of 3
.. ..$ 1: symbol {
.. ..$ 2: language nr2 <- max(sapply(variables, NROW))
.. ..$ 3:List of 3
.. .. ..$ 1: symbol if
.. .. ..$ 2: language nr2 != nr
.. .. ..$ 3: language warning(gettextf("'newdata' had %d rows but variable(s) found have %d rows", nr, nr2), call. = FALSE)
20:List of 3
..$ 1: symbol if
..$ 2: language is.null(attr(formula, "predvars"))
..$ 3:List of 3
.. ..$ 1: symbol {
.. ..$ 2:List of 4
.. .. ..$ 1: symbol for
.. .. ..$ 2: symbol i
.. .. ..$ 3: language seq_along(varnames)
.. .. ..$ 4: language predvars[[i + 1]] <- makepredictcall(variables[[i]], vars[[i + 1]])
.. ..$ 3: language attr(formula, "predvars") <- predvars
21: language extras <- substitute(list(...))
22: language extranames <- names(extras[-1L])
23: language extras <- eval(extras, data, env)
24: language subset <- eval(substitute(subset), data, env)
25: language data <- .Internal(model.frame(formula, rownames, variables, varnames, extras, extranames, subset, na.action))
26:List of 4
..$ 1: symbol if
..$ 2: language length(xlev)
..$ 3:List of 2
.. ..$ 1: symbol {
.. ..$ 2:List of 4
.. .. ..$ 1: symbol for
.. .. ..$ 2: symbol nm
.. .. ..$ 3: language names(xlev)
.. .. ..$ 4:List of 3
.. .. .. ..$ 1: symbol if
.. .. .. ..$ 2: language !is.null(xl <- xlev[[nm]])
.. .. .. ..$ 3:List of 4
.. .. .. .. ..$ 1: symbol {
.. .. .. .. ..$ 2: language xi <- data[[nm]]
.. .. .. .. ..$ 3:List of 3
.. .. .. .. .. ..$ 1: symbol if
.. .. .. .. .. ..$ 2: language is.character(xi)
.. .. .. .. .. ..$ 3:List of 3
.. .. .. .. .. .. ..$ 1: symbol {
.. .. .. .. .. .. ..$ 2: language xi <- as.factor(xi)
.. .. .. .. .. .. ..$ 3: language warning(gettextf("character variable '%s' changed to a factor", nm), domain = NA)
.. .. .. .. ..$ 4:List of 4
.. .. .. .. .. ..$ 1: symbol if
.. .. .. .. .. ..$ 2: language !is.factor(xi) || is.null(nxl <- levels(xi))
.. .. .. .. .. ..$ 3: language warning(gettextf("variable '%s' is not a factor", nm), domain = NA)
.. .. .. .. .. ..$ 4:List of 5
.. .. .. .. .. .. ..$ 1: symbol {
.. .. .. .. .. .. ..$ 2: language xi <- xi[, drop = TRUE]
.. .. .. .. .. .. ..$ 3: language nxl <- levels(xi)
.. .. .. .. .. .. ..$ 4:List of 3
.. .. .. .. .. .. .. ..$ 1: symbol if
.. .. .. .. .. .. .. ..$ 2: language any(m <- is.na(match(nxl, xl)))
.. .. .. .. .. .. .. ..$ 3: language stop(gettextf("factor '%s' has new level(s) %s", nm, paste(nxl[m], collapse = ", ")), domain = NA)
.. .. .. .. .. .. ..$ 5: language data[[nm]] <- factor(xi, levels = xl, exclude = NULL)
..$ 4:List of 3
.. ..$ 1: symbol if
.. ..$ 2: symbol drop.unused.levels
.. ..$ 3:List of 2
.. .. ..$ 1: symbol {
.. .. ..$ 2:List of 4
.. .. .. ..$ 1: symbol for
.. .. .. ..$ 2: symbol nm
.. .. .. ..$ 3: language names(data)
.. .. .. ..$ 4:List of 3
.. .. .. .. ..$ 1: symbol {
.. .. .. .. ..$ 2: language x <- data[[nm]]
.. .. .. .. ..$ 3:List of 3
.. .. .. .. .. ..$ 1: symbol if
.. .. .. .. .. ..$ 2: language is.factor(x) && length(unique(x[!is.na(x)])) < length(levels(x))
.. .. .. .. .. ..$ 3: language data[[nm]] <- data[[nm]][, drop = TRUE]
27: language attr(formula, "dataClasses") <- sapply(data, .MFclass)
28: language attr(data, "terms") <- formula
29: symbol data
这是一个方便的包装检测件:
library(codetools)
ff <- function(f, tar) {
cc <- function(e, w) {
if(length(w$pos) > 0 &&
grepl(w$tar, paste(deparse(e), collapse = "\n"), fixed = TRUE)) {
cat(rev(w$pos), ": ", deparse(e), "\n")
w$ret$vals <- c(w$ret$vals, list(rev(w$pos)))
}
w$pos <- c(0, w$pos)
for (ee in as.list(e)){
if (!missing(ee)) {
w$pos[1] <- w$pos[1] + 1
walkCode(ee, w)
}
}
}
w <- list(pos = c(),
tar = tar,
ret = new.env(),
handler = function(v, w) NULL,
call = cc,
leaf = function(e, w) NULL)
walkCode(body(f), w = w)
w$ret$vals
}
然后,
> r <- ff(pretty.default, "delta <- diff(range(z$l, z$u))/z$n")
12 : if (!eps.correct && z$n) { delta <- diff(range(z$l, z$u))/z$n if (any(small <- abs(s) < 1e-14 * delta)) s[small] <- 0 }
12 3 : { delta <- diff(range(z$l, z$u))/z$n if (any(small <- abs(s) < 1e-14 * delta)) s[small] <- 0 }
12 3 2 : delta <- diff(range(z$l, z$u))/z$n
> r
[[1]]
[1] 12
[[2]]
[1] 12 3
[[3]]
[1] 12 3 2
> r <- ff(model.frame.default, "stop(gettextf(\"factor '%s' has new level(s) %s\", nm, paste(nxl[m],")
26 3 2 4 3 4 4 4 3 : stop(gettextf("factor '%s' has new level(s) %s", nm, paste(nxl[m], collapse = ", ")), domain = NA)
> r
[[1]]
[1] 26 3 2 4 3 4 4 4 3
你可以按内容定义跟踪器:
traceby <- function(fun, tar, cer) {
untrace(deparse(substitute(fun)))
r <- ff(fun, tar)
r <- r[which.max(sapply(r, length))]
trace(what = deparse(substitute(fun)), tracer = cer, at = r)
}
然后,
> traceby(pretty.default, "if (any(small <- abs(s) < 1e-14 * delta)) s[small] <- 0", quote(cat("\nThe value of delta is: ", delta, "\n\n")))
Untracing function "pretty.default" in package "base"
12 3 3 : if (any(small <- abs(s) < 1e-14 * delta)) s[small] <- 0
Tracing function "pretty.default" in package "base"
[1] "pretty.default"
> a <- pretty(c(1, 7843))
Tracing pretty.default(c(1, 7843)) step 12,3,3
The value of delta is: 2000
> b <- pretty(c(2, 23))
Tracing pretty.default(c(2, 23)) step 12,3,3
The value of delta is: 5
| 归档时间： |
|
| 查看次数： |
887 次 |
| 最近记录： |