21

Preamble:

R's trace() is a powerful debugging tool, allowing users to "insert debugging code at chosen places in any function". Unfortunately, using it from the command-line can be fairly laborious.

As an artificial example, let's say I want to insert debugging code that will report the between-tick interval calculated by pretty.default(). I'd like to insert the code immediately after the value of delta is calculated, about four lines up from the bottom of the function definition. (Type pretty.default to see where I mean.) To indicate that line, I need to find which step in the code it corresponds to. The answer turns out to be step list(c(12, 3, 3)), which I zero in on by running through the following steps:

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]]

I can then insert debugging code like this:

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')

Questions:

So here are my questions: Is there a way to print out a function (or a parsed version of it) with the lines nicely labeled by the steps to which they belong? (According to Venables and Ripley, S-plus has a function tprint() that "produces a numbered listing of the body of a function for use with the at argument of trace", but R seems to have no equivalent.) Alternatively, is there another easier way, from the command line, to quickly set debugging code for a specific line within a function?

Addendum:

I used the pretty.default() example because it is reasonably tame, but with real/interesting functions, repeatedly using as.list() quickly gets tiresome and distracting. Here's an example:

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]]
4

3 回答 3

8

pretty.default这里有一些对and非常有效的东西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
于 2012-07-03T21:53:20.853 回答
8

这是一个方便的包装器，用于检测该片段：

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
于 2012-07-04T01:09:49.617 回答
1

这是一种利用包中可用于确定与给定源文件中指定行相对应的步骤这一事实findLineNum()的方法。utils

getStep <- function(fun, txt) {
    ## Create a text file into which the function can dumped
    ## and from which it can then be sourced
    tmpfile <- tempfile() 
    on.exit(unlink(tmpfile))
    dump(fun, file = tmpfile)
    ## Find the line containing the code of interest
    lines <- readLines(tmpfile)
    matchlines <- grepl(txt, lines, fixed=TRUE)
    if(sum(matchlines) > 1) {
        stop(paste(dQuote(txt), "matches more than one line in", fun))
    }
    linenum <- which(matchlines)
    ## Use findLineNum() to determine the step corresponding to that line
    source(tmpfile)
    Step <- list(findLineNum(tmpfile, line=linenum)[[1]]$at)
    ## Clean up and return
    rm(list = fun, envir = .GlobalEnv)
    return(Step)
}

## Test it
getStep(fun = "pretty.default",
        txt = "if (any(small <- abs(s) < 1e-14 * delta))")
# [[1]]
# [1] 6  3  3

然后将一小步合并getStep()到一个函数中，该函数fun在行匹配处插入调试代码txt。

## Define the function
traceLine <- function(fun, txt, tracer) {
    Step <- getStep(fun = deparse(substitute(fun)), txt = txt)
    trace(what = substitute(fun),
          tracer = tracer,
          at = Step)
}

## Confirm that it works.
traceLine(fun = pretty.default,
          txt = "if (any(small <- abs(s) < 1e-14 * delta))",
          tracer = quote(cat("\nThe value of delta is: ", delta, "\n\n")))
a <- pretty(c(1, 7843))
b <- pretty(c(2, 23))
untrace(pretty.default)
于 2012-07-04T07:12:38.600 回答