将函数作为输入并在调用时使其表达式可见的函数

Question

在this SO question 的基础上，我想编写一个操作其他函数的函数，方法是 (1) 将每一行设置为可见 () 和 (2) 将 withAutoprint({}) 包裹在函数体周围。首先，我虽然对trace() 的一些调用会产生我想要的结果，但不知何故我无法弄清楚。

这是一个简单的例子：

# 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

背景/动机

在没有引发真正错误的情况下，逐行显示函数对较长的自定义函数很有帮助，但函数会出现错误的转向并返回和不需要的输出。另一种方法是使用调试器单击下一步并逐步检查每个变量。像make_visible 这样的函数可能会在这里节省一些时间。

用例

我看到了这种函数的实际用例，在调试 map 或 lapply 函数时，这些函数不会出现错误，但会在正在循环的函数的某处产生不希望的结果。

Answer 1

这是一个解决方案，它可以准确地创建您在问题中提出的解决方案的主体，并添加了您在答案中使用的 2 个测试：

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

这是另一种看法，打印得更好，作为您自己的第二个提案：

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

我想出了两种不同的方法来解决上述我自己的问题。他们俩都使用了我称之为“深度功能黑客”的东西，这可能不是推荐的这样做方式——至少看起来根本不应该这样做。在玩之前，我什至不知道这是可能的。可能有更清洁和更推荐的方法来做到这一点，因此我将这个问题留给其他方法。

第一种方法

我将第一种方法的函数称为make_visible。基本上，此函数使用foo 的主体部分构造一个新函数，并在( 和withAutoprint 中用for 循环包装那些。它非常 hacky，并且仅适用于函数的第一级（它不会显示更深层次的结构，例如，使用管道的函数）。

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

}

产生以下结果：

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

这种方法有几个缺点： 1.将每一行的输出包裹在括号中，降低了可读性 2.此外，这种方法返回的不是原始函数的值，而是一个包含两个元素的列表，原始结果value和一个逻辑向量visible，这使得这个函数的输出更难使用，尤其是在map 调用中使用它时。

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

第二种方法

虽然make_visible 是我通过使每一行可见并将其包装在withAutoprint 中来重写函数的想法的直接方法，但第二种方法重新考虑了问题。这是一个类似的“深度函数破解”，循环遍历原始函数的主体部分，但这次（1）将它们打印到控制台，（2）捕获它们的评估输出，（3）将此输出打印到控制台，然后（ 4）实际评估每个身体部位。最后，原始函数被调用并以不可见的方式返回。

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

}

输出看起来相似但更清晰：

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

第二种方法更好，因为它更具可读性，并且返回与原始函数相同的值。但是，目前我无法在map 调用中使其工作。这可能是由于弄乱了函数环境。

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