Function which takes function as input and makes its expressions visible when called

Question

Building on this SO question here I want to write a function that manipulates other functions by (1) setting each line visible () and by (2) wrapping withAutoprint({}) around the body of the function. First, I though some call to trace() would yield my desired result, but somehow I can't figure it out.

Here is a simple example:

# Input function foo
foo <- function(x)
{
  line1 <- x
  line2 <- 0
  line3 <- line1 + line2
  return(line3)
}

# some function which alters foo (here called make_visible() )
foo2 <- make_visible(foo)

# so that foo2 looks like this after being altered
foo2 <- function(x)
{
 withAutoprint({
  (line1 <- x)
  (line2 <- 0)
  (line3 <- line1 + line2)

  (return(line3))
 })
}

# example of calling foo2 and desired output/result
> foo2(2)
> (line1 <- x)
[1] 2
> (line2 <- 0)
[1] 0
> (line3 <- line1 + line2)
[1] 2
> (return(line3))
[1] 2

background / motivation

Turning functions visible line by line is helpful with longer custom functions when no real error is thrown, but the functions takes a wrong turn and returns and unwanted output. The alternative is using the debugger clicking next and checking each variable step by step. A function like make_visible might save some time here.

Use case

I see an actual use case for this kind of function, when debugging map or lapply functions which do not through an error, but produce an undesired result somewhere in the function that is being looped over.

Answer 1

Here's a solution that creates exactly the body of the solution you proposed in your question, with the addition of the 2 tests you used in your answer :

make_visible <- function(f) {
  if (typeof(f) %in% c("special", "builtin")) {
    stop("make_visible cannot be applied to primitive functions")
  }

  if (! typeof(f) %in% "closure") {
    stop("make_visible only takes functions of type closures as argument")
  }
  f2 <- f
  bod <- body(f)
  if(!is.call(bod) || !identical(bod[[1]], quote(`{`)))
    bod <- call("(",body(f))
  else
    bod[-1] <- lapply(as.list(bod[-1]), function(expr) call("(", expr))
  body(f2) <- call("[[",call("withAutoprint", bod),"value")
  f2
}

# solve foo issue with standard adverb way
foo <- function(x)
{
  line1 <- x
  line2 <- 0
  line3 <- line1 + line2
  return(line3)
}

foo2 <- make_visible(foo)

foo2
#> function (x) 
#> withAutoprint({
#>     (line1 <- x)
#>     (line2 <- 0)
#>     (line3 <- line1 + line2)
#>     (return(line3))
#> })[["value"]]

foo2(2)
#> > (line1 <- x)
#> [1] 2
#> > (line2 <- 0)
#> [1] 0
#> > (line3 <- line1 + line2)
#> [1] 2
#> > (return(line3))
#> [1] 2
#> [1] 2

Here's another take, printing nicer as your own second proposal :

make_visible2 <- function(f) {
  if (typeof(f) %in% c("special", "builtin")) {
    stop("make_visible cannot be applied to primitive functions")
  }

  if (! typeof(f) %in% "closure") {
    stop("make_visible only takes functions of type closures as argument")
  }
  f2 <- f
  bod <- body(f)
  if(!is.call(bod) || !identical(bod[[1]], quote(`{`))) {
    bod <- bquote({
      message(deparse(quote(.(bod))))
      print(.(bod))
    })
  }  else {
    bod[-1] <- lapply(as.list(bod[-1]), function(expr) {
      bquote({
        message(deparse(quote(.(expr))))
        print(.(expr))
      })
    })
  }
  body(f2) <- bod
  f2
}

foo3 <- make_visible2(foo)
foo3
#> function (x) 
#> {
#>     {
#>         message(deparse(quote(line1 <- x)))
#>         print(line1 <- x)
#>     }
#>     {
#>         message(deparse(quote(line2 <- 0)))
#>         print(line2 <- 0)
#>     }
#>     {
#>         message(deparse(quote(line3 <- line1 + line2)))
#>         print(line3 <- line1 + line2)
#>     }
#>     {
#>         message(deparse(quote(return(line3))))
#>         print(return(line3))
#>     }
#> }

foo3(2)
#> line1 <- x
#> [1] 2
#> line2 <- 0
#> [1] 0
#> line3 <- line1 + line2
#> [1] 2
#> return(line3)
#> [1] 2

Answer 2

I figured out two different approaches to my own question above. Both of them use something I would call 'deep function hacking' which is probably not a recommended way of doing this - at least it doesn't look like one should be doing this at all. Before playing around I didn't know this was even possible. Probably there are cleaner and more recommended ways of doing this, therefore I leave this questions open for other approaches.

First approach

I call the function of the first approach make_visible. Basically, this function constructs a new function using the body parts of foo and wrapping those with for loops in ( and then in withAutoprint. It is quite hacky, and only works on the first level of a function (it won't show the deeper structure of, for example, functions that use pipes).

make_visible <- function(.fx) {

  if (typeof(.fx) %in% c("special", "builtin")) {
    stop("`make_visible` cannot be applied to primitive functions")
  }

  if (! typeof(.fx) %in% "closure") {
    stop("`make_visible` only takes functions of type closures as argument")
  }

  # make environment of .fx parent environment of new function environment
  org_e <- environment()
  fct_e <- environment(.fx)
  parent.env(org_e) <- fct_e

  # get formals and body of input function .f
  fct_formals <- formals(.fx)
  fct_body <- body(.fx)[-1]

  # create a minimal example function for `(`
  .f1 <- function(x) {
    (x) 
  }

  # extract its body
  .f1_body <- body(.f1)[-1]

  # build a new function .f2 by combining .f and .f1
  .f2 <- function() {}

  for (i in seq_along(1:length(fct_body))) {

    .f1_body[[1]][[2]]<- fct_body[[i]]

    body(.f2)[[1+i]] <- .f1_body[[1]]

  }

  # extract the body of new function .f2
  .f2_body <- body(.f2)[-1]

  # create a minimal example function .f3 for `withAutoprint`
  .f3 <- function() {

    withAutoprint({
      x
    })

  }

  # insert body part of .f2 into .f3
  for (j in seq_along(1:length(.f2_body))) {

    body(.f3)[[2]][[2]][[1+j]] <- .f2_body[[j]]

  }

  # give .f3 the formals of input function
  formals(.f3) <- fct_formals

  # return .f3 as new function
  .f3

}

Which yields the following outcome:

foo2 <- make_visible(foo)
foo2(1)
> (line1 <- x)
> [1] 1
> (line2 <- 0)
> [1] 0
> (line3 <- line1 + line2)
> [1] 1
> (return(line3))
> [1] 1

This approach has a couple of downsides: 1. Wrapping the output of each line into brackets reduced the readability 2. Further, this approach returns a not the value of the original function, but a list with two elements, the original result value and a logical vector visible, which makes it harder to use the output of this function, especially when using it inside a map call.

foo2(1) %>% str
# > (line1 <- x)
# [1] 1
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 1
# > (return(line3))
# [1] 1
# List of 2
# $ value  : num 1
# $ visible: logi TRUE

purrr::map(1:3, foo2)
# > (line1 <- x)
# [1] 1
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 1
# > (return(line3))
# [1] 1
# > (line1 <- x)
# [1] 2
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 2
# > (return(line3))
# [1] 2
# > (line1 <- x)
# [1] 3
# > (line2 <- 0)
# [1] 0
# > (line3 <- line1 + line2)
# [1] 3
# > (return(line3))
# [1] 3
# [[1]]
# [[1]]$value
# [1] 1
#
# [[1]]$visible
# [1] TRUE
#
#
# [[2]]
# [[2]]$value
# [1] 2
# 
# [[2]]$visible
# [1] TRUE
# 
#
# [[3]]
# [[3]]$value
# [1] 3
# 
# [[3]]$visible
# [1] TRUE

Second approach

While make_visible is a direct approach on my idea of rewriting a function by making each line visible and wrapping it in withAutoprint the second approach rethinks the problem. It is a similar 'deep function hack', looping over body parts of the original function, but this time (1) printing them to console, (2) capturing their evaluated output, (3) printing this output to console, and then (4) actually evaluating each body part. Finally the original function is called and returned invisibly.

reveal <- function(.fx) {

  if (typeof(.fx) %in% c("special", "builtin")) {
    stop("`reveal` cannot be applied to primitive functions")
  }

  if (! typeof(.fx) %in% "closure") {
    stop("`reveal` only takes functions of type closures as argument")
  }


  # environment handling
  # get environment of .fx and make it parent.env of reveal
  org_e <- environment()
  fct_e <- environment(.fx)
  parent.env(org_e) <- fct_e

  # get formals of .fx
  fct_formals <- formals(.fx)

  # get body of .fx without first part { 
  fct_body <- body(.fx)[-1]

  # define new function to return
  .f2 <- function() {

    # loop over the body parts of .fx
    for (.i in seq_along(1:length(fct_body))) {

      # print each body part 
      cat(paste0(as.list(fct_body)[.i],"\n"))

      # check whether eval returns output and if not use eval_tidy
      if (length(capture.output(eval(fct_body[[.i]]))) == 0) {

        # write output of eval as string
        out <- capture.output(rlang::eval_tidy(fct_body[[.i]]))

      } else {

        # write output of eval as string
        out <- capture.output(eval(fct_body[[.i]]))
      }

      # print output of evaluation
      cat(out, sep = "\n")

      # evaluate
      eval(fct_body[[.i]])

    }

    # get arguments
    .args <- match.call(expand.dots = FALSE)[-1]

    # run .fx with .args and return result invisibly 
    invisible(do.call(.fx, as.list(.args)))

  }

  # replace formals of .f2 with formals of .fx  
  formals(.f2) <- fct_formals

  # replace environment of .f2 with env of reveal to which env of .fx is a parent environment
  environment(.f2) <- org_e

  # return new function .f2
  .f2

}

The output looks similar but somewhat cleaner:

reveal(foo)(1)
> line1 <- x
> [1] 1
> line2 <- 0
> [1] 0
> line3 <- line1 + line2
> [1] 1
> return(line3)
> [1] 1

This second approach is better because it's more readable and it returns the same value as the original function. However, at the moment I havent't been able to make it work inside a map call. This is probably due to messing with the function environments.

foo2 <- reveal(foo)
purrr::map(1:3, foo2)
#>  Error in (function (x)  : object '.x' not found