This is not nearly as interesting as it might first sound, but every function in R contains R code; this is true of core R code as well as extension packages. Sometimes the R code is just a very shallow wrapper around some compiled code, such as in sum() and is.null(). Other times, as in lm.fit(), there is a vast expanse of R code.
It’s easy enough to print this source code; simply type in the function name without any parentheses or arguments. A nice way to search through that output from inside of R is to use capture.output() and then use standard regex utilities like grep(). Any standard printing to the R terminal (done via Rprintf) will be captured like a readLines() call, either inside R itself or to a file, depending on function arguments. This is R’s version of redirecting stdout with >, and here the usual caveats apply; i.e., errors and warnings are not captured:
example <- capture.output(print("asdf"))
example
#[1] "[1] \\"asdf\\""
example <- capture.output(warning("asdf"))
#Warning message:
#In eval(expr, envir, enclos) : asdf
example
#character(0)
example <- capture.output(stop("asdf"))
#Error in eval(expr, envir, enclos) : asdf
example
#character(0)
But otherwise, it behaves exactly like you might expect:
x <- matrix(1:30, nrow=10)
y <- capture.output(x)
y
# [1] " [,1] [,2] [,3]" " [1,] 1 11 21" " [2,] 2 12 22"
# [4] " [3,] 3 13 23" " [4,] 4 14 24" " [5,] 5 15 25"
# [7] " [6,] 6 16 26" " [7,] 7 17 27" " [8,] 8 18 28"
#[10] " [9,] 9 19 29" "[10,] 10 20 30"
cat(paste(y, "
"))
# [,1] [,2] [,3]
# [1,] 1 11 21
# [2,] 2 12 22
# [3,] 3 13 23
# [4,] 4 14 24
# [5,] 5 15 25
# [6,] 6 16 26
# [7,] 7 17 27
# [8,] 8 18 28
# [9,] 9 19 29
# [10,] 10 20 30
Clearly this utility makes our original problem completely trivial. For example, say we are interested in the cov() function:
capture.output(cov)
#[1] "function (x, y = NULL, use = \\"everything\\", method =
c(\\"pearson\\", "
#[2] " \\"kendall\\", \\"spearman\\")) "
#[3] "{"
#[4] " na.method <- pmatch(use, c(\\"all.obs\\",
\\"complete.obs\\", \\"pairwise.complete.obs\\", "
# and so on...
Maybe we want to see all the .Call() lines:
x <- capture.output(cov)
x[grep(x=x, pattern="[.]Call")]
#[1] " .Call(C_cov, x, y, na.method, method == \\"kendall\\")"
#[2] " .Call(C_cov, Rank(na.omit(x)), NULL, na.method, method == "
#[3] " .Call(C_cov, Rank(dropNA(x, nas)), Rank(dropNA(y, "
#[4] " .Call(C_cov, x, y, na.method, method == \\"kendall\\")"
And we can quickly turn this into a useful function using a bit more of R’s expressive sneakiness:
stopper <- function(fun)
{
stop(paste("in match_src() : function fun='", fun, "' not found",
sep=""), call.=FALSE)
}
match_src <- function(fun, pattern, ignore.case=FALSE, perl=FALSE,
value=FALSE, fixed=FALSE, useBytes=FALSE, invert=FALSE,
remove.comments=TRUE)
{
### This is really too complicated, I apologize
err <- try(test <- is.character(fun), silent=TRUE)
if (inherits(x=err, what="try-error"))
stopper(fun=deparse(substitute(fun)))
else if (test)
{
err <- try(fun <- eval(as.symbol(fun)), silent=TRUE)
if (inherits(x=err, what="try-error"))
stopper(fun=fun)
}
err <- try(expr=src <- capture.output(fun), silent=TRUE)
if (inherits(x=err, what="try-error"))
stopper(fun=deparse(substitute(fun)))
# Remove comments
if (remove.comments) # test
{
src <- sub(src, pattern="#.*", replacement="")
num.empty <- which(src == "")
if (length(num.empty) > 0)
src <- src[-num.empty]
src <- sub(x=src, pattern="[ \\t]+\$", replacement="")
}
### Get matches and scrub
matches <- grep(x=src, pattern=pattern, ignore.case=ignore.case,
perl=perl, value=value, fixed=fixed, useBytes=useBytes, invert=invert)
src <- src[matches]
# remove leading and trailing whitespace
src <- sub(x=src, pattern="^[ \\t]+|[ \\t]+\$", replacement="")
return( src )
}
With example outputs:
match_src(match_src, pattern="comment")
#[1] "function(fun, pattern, ignore.case=FALSE, perl=FALSE,
value=FALSE, fixed=FALSE, useBytes=FALSE, invert=FALSE,
remove.comments=TRUE)"
#[2] "if (remove.comments)"
match_src(match_src, pattern="comment", remove.comments=FALSE)
#[1] "function(fun, pattern, ignore.case=FALSE, perl=FALSE,
value=FALSE, fixed=FALSE, useBytes=FALSE, invert=FALSE,
remove.comments=TRUE)"
#[2] "# Remove comments"
#[3] "if (remove.comments) # test"
match_src("match_src", pattern="comment")
#[1] "function(fun, pattern, ignore.case=FALSE, perl=FALSE,
value=FALSE, fixed=FALSE, useBytes=FALSE, invert=FALSE,
remove.comments=TRUE)"
#[2] "if (remove.comments)"
match_src(match_srcs, pattern="comment")
#Error: in match_src() : function fun='match_srcs' not found
And here’s everything in a github gist if that’s more your style.