What is a fast way to set debugging code at a given line in a function?

Question

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

Answer 1

Here's something that works pretty well for 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
  }
}

Results for 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

Results for 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

Answer 2

Here is a convenient wrapper for detecting the piece:

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
}

and then,

> 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

and you can define the tracer by contents:

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

then,

> 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 

Answer 3

Here's an approach which takes advantage of the fact that findLineNum() in the utils package can be used to determine the step corresponding to a specified line in a given source file.

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

It's then a small step to incorporate getStep() in a function that inserts debugging code in function fun at the line matching 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)