Merge pull request #264 from rstudio/feature/debug-hooks

Export installExprFunction and add supporting documentation

R/shinywrappers.R

@@ -2,6 +2,7 @@ suppressPackageStartupMessages({
   library(caTools)
   library(xtable)
 })
+globalVariables('func')
 
 #' Plot Output
 #' 
@@ -42,11 +43,9 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   if (!is.null(func)) {
     shinyDeprecated(msg="renderPlot: argument 'func' is deprecated. Please use 'expr' instead.")
   } else {
-    func <- exprToFunction(expr, env, quoted)
-    registerDebugHook("func", environment(), "Render Plot")
+    installExprFunction(expr, "func", env, quoted)
   }
 
-
   args <- list(...)
   
   if (is.function(width))
@@ -221,8 +220,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #' }
 renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
                         deleteFile=TRUE) {
-  func <- exprToFunction(expr, env, quoted)
-  registerDebugHook("func", environment(), "Render Image")
+  installExprFunction(expr, "func", env, quoted)
   
   return(function(shinysession, name, ...) {
     imageinfo <- func()
@@ -272,8 +270,7 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
   if (!is.null(func)) {
     shinyDeprecated(msg="renderTable: argument 'func' is deprecated. Please use 'expr' instead.")
   } else {
-    func <- exprToFunction(expr, env, quoted)
-    registerDebugHook("func", environment(), "Render Table")
+    installExprFunction(expr, "func", env, quoted)
   }
 
   function() {
@@ -330,8 +327,7 @@ renderPrint <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
   if (!is.null(func)) {
     shinyDeprecated(msg="renderPrint: argument 'func' is deprecated. Please use 'expr' instead.")
   } else {
-    func <- exprToFunction(expr, env, quoted)
-    registerDebugHook("func", environment(), "Render Print")
+    installExprFunction(expr, "func", env, quoted)
   }
 
   function() {
@@ -374,8 +370,7 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
   if (!is.null(func)) {
     shinyDeprecated(msg="renderText: argument 'func' is deprecated. Please use 'expr' instead.")
   } else {
-    func <- exprToFunction(expr, env, quoted)
-    registerDebugHook("func", environment(), "Render Text")
+    installExprFunction(expr, "func", env, quoted)
   }
 
   function() {
@@ -415,8 +410,7 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
   if (!is.null(func)) {
     shinyDeprecated(msg="renderUI: argument 'func' is deprecated. Please use 'expr' instead.")
   } else {
-    func <- exprToFunction(expr, env, quoted)
-    registerDebugHook("func", environment(), "Render UI")
+    installExprFunction(expr, "func", env, quoted)
   }
 
   function() {

R/utils.R

@@ -130,6 +130,8 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #' @param env The desired environment for the function. Defaults to the
 #'   calling environment two steps back.
 #' @param quoted Is the expression quoted?
+#' @param caller_offset If specified, the offset in the callstack of the 
+#'   functiont to be treated as the caller. 
 #'
 #' @examples
 #' # Example of a new renderer, similar to renderText
@@ -165,9 +167,10 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #' # "text, text, text"
 #'
 #' @export
-exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE) {
+exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE, 
+                           caller_offset=1) {
   # Get the quoted expr from two calls back
-  expr_sub <- eval(substitute(substitute(expr)), parent.frame())
+  expr_sub <- eval(substitute(substitute(expr)), parent.frame(caller_offset))
 
   # Check if expr is a function, making sure not to evaluate expr, in case it
   # is actually an unquoted expression.
@@ -176,8 +179,8 @@ exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE) {
   # latter, it will be a language object.
   if (!is.name(expr_sub) && expr_sub[[1]] == as.name('function')) {
     # Get name of function that called this function
-    called_fun <- sys.call(-1)[[1]]
-
+    called_fun <- sys.call(-1 * caller_offset)[[1]]
+    
     shinyDeprecated(msg = paste("Passing functions to '", called_fun,
       "' is deprecated. Please use expressions instead. See ?", called_fun,
       " for more information.", sep=""))
@@ -193,6 +196,37 @@ exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE) {
   }
 }
 
+#' Installs an expression in the given environment as a function, and registers
+#' debug hooks so that breakpoints may be set in the function.
+#' 
+#' Can replace \code{exprToFunction} as follows:
+#' 
+#' Before: \code{func <- exprToFunction(expr)}
+#' 
+#' After: \code{installExprFunction(expr, "func")}
+#' 
+#' @seealso Wraps \code{exprToFunction}; see that method's documentation for 
+#'   more documentation and examples.
+#'   
+#' @param expr A quoted or unquoted expression
+#' @param name The name the function should be given 
+#' @param eval.env The desired environment for the function. Defaults to the
+#'   calling environment two steps back. 
+#' @param quoted Is the expression quoted?
+#' @param assign.env The environment in which the function should be assigned.
+#' @param label A label for the object to be shown in the debugger. Defaults
+#'   to the name of the calling function. 
+#' 
+#' @export
+installExprFunction <- function(expr, name, eval.env = parent.frame(2), 
+                                quoted = FALSE, 
+                                assign.env = parent.frame(1),
+                                label = as.character(sys.call(-1)[[1]])) {
+  func <- exprToFunction(expr, eval.env, quoted, 2)
+  assign(name, func, envir = assign.env)
+  registerDebugHook(name, assign.env, label)
+}
+
 #' Parse a GET query string from a URL
 #'
 #' Returns a named character vector of key-value pairs.