从源文件中提取所有函数而不对其进行评估

Question

对于我的包，我正在寻找一种方法来识别用户提供的R脚本中的所有函数分配，没有执行它。

因此，让我们假设以下示例脚本 (ex.R)：

ex.R

## user supplied script
a <- function(x) 1
b1 = b2 <- function() {
   y <- 1
   2 -> j
   j
}
d <<- function(x) {
   k <- function(l) 1
   k(x)
}
(function(x) 2) -> e
(function() {
   y <- 1
   2 -> j
   j
}) -> f1 -> f2
(function() 1)()
g <- 4
5 -> h
i <- lapply(1:3, FUN = function(x) x + 1)
assign('j', function() 1)
k1 <- (function() {1}) -> k2

该函数应返回c("a", "b1", "b2", "d", "e", "f1", "f2", "j", "k1", "k2")

我想出了以下解决方案：

library(dplyr)
code <- parse("ex.R")

get_identifier <- function(nm) {
   if (is.symbol(nm)) {
      deparse(nm)
   } else if (is.character(nm)) {
      nm
   } else {
      stop(paste0("unknown type", typeof(nm), "for `nm`"))
   }
}

get_fns <- function(expr) {
   assignment_ops <- c("<-", "=", "assign", "<<-")
   is_assign <- deparse(expr[[1L]]) %in% assignment_ops
   is_call <- is_assign && is.call(expr[[3L]])
   if (is_call) {
      next_call <- deparse(expr[[3L]][[1L]])
      if (next_call == "function") {
         get_identifier(expr[[2L]])
      } else if (next_call %in% c(assignment_ops, "(")) {
         c(get_identifier(expr[[2L]]), Recall(expr[[3L]]))
      } else {
         NULL
      }
   } else {
      NULL
   }
}

unlist(lapply(code, get_fns))
# [1] "a"  "b1" "b2" "d"  "e"  "f2" "f1" "j"  "k1" "k2"

这至少对于这个用例是正确的。

但是只添加另外两个讨厌的边缘情况会破坏代码：

l1 <- (1 + (l2 <- function(x) 2 * x)(3))
(m <- function(x) x)

应该返回c("l2", "m")，但它没有。我的递归有问题，但我无法发现问题所在。我将如何修复代码？

---

更新

评论表明我应该解释一下我最终想要实现的目标：

1. 我想开发一个包，它采用“任意”R 脚本（script.R say）并将此脚本转换为具有命令行界面的脚本（script_ammended.R say），最终可以调用通过Rscript ammended_script.R [ARGS]。
2. 想法是用户脚本包含一些函数和一些特殊的 cmets，并通过这些函数自动生成 CLI。
3. 我知道有几个库已经可以进行不错的命令行解析，但是所有这些库当然都需要用户花一些时间进行 CLI 编程。
4. 我的用例有些不同。我想要一个独立的脚本，它只使用一些函数来完成它想要做的事情。如果用户以后想用它创建一个 CL 工具，应该就像按一个按钮一样简单（假设用户向原始功能添加了一些最小的 cmets）。
5. 自动生成的脚本将始终添加额外的代码、记录、确保安装所需的库等。

   一个人为的例子可能是这样的：

   script.R

   greet <- function(msg, from = "me") {
      #! short: -g
      #! params: [., -f]
      #! description: greeting <msg> from user <me> is shown
      print(paste0("Message from <", from, ">: ", msg))
   }
   
   bye <- function() {
      #! short: -b
      greet("Good Bye", "system")
   }
   
   greet("Test")
   

   这将是一个典型的用户脚本，可以非常方便地以交互方式使用。现在，我的包应该采用此脚本并将其转换为以下脚本：

   script_amended.R

   library(optigrab)
   
   greet <- function(msg, from = "me") {
      print(paste0("Message from <", from, ">: ", msg))
   }
   
   bye <- function() {
      greet("Good Bye", "system")
   }
   
   msg <- opt_get("g", default = NA_character_, 
                  description = "greeting <msg> from user <me> is shown")
   from <- opt_get("f", default = "me")
   bye_flag <- opt_get("b", default = FALSE)
   
   
   if (!is.na(msg)) {
      greet(msg, from)
      quit(status = 0)
   } else if (bye_flag) {
      bye()
      quit(status = 0)
   }
   

Answer 1

感谢 Allan Cameron 的 cmets 来运行脚本，下面是一个使用该方法的函数。

functions_from_source <- function(source) {
  
  myEnv <- new.env()  
  
  source(source, local = myEnv)
  
  objects <- ls(envir = myEnv)
  
  funs <- sapply(objects, (x){
    is.function(eval(parse(text = x), envir = myEnv))
  })
  
  objects[funs]
  
  rm(envir = myEnv)
  
}

functions_from_source("ex.R")

# [1] "a"  "b1" "b2" "e"  "f1" "f2" "j"  "k1" "k2" "m"

ex.R包括 m 和 l1（注意 R 不将 l2 解释为函数而是值）

a <- function(x) 1
b1 = b2 <- function() {
  y <- 1
  2 -> j
  j
}
d <<- function(x) {
  k <- function(l) 1
  k(x)
}
(function(x) 2) -> e
(function() {
  y <- 1
  2 -> j
  j
}) -> f1 -> f2
(function() 1)()
g <- 4
5 -> h
i <- lapply(1:3, FUN = function(x) x + 1)
assign('j', function() 1)
k1 <- (function() {1}) -> k2

l1 <- (1 + (l2 <- (function(x) 2 * x)(3)))
(m <- function(x) x)

Answer 2

尝试减少功能：虽然可能有一些边缘情况。没有把握。

get_fun <- function(x){
  dp <- deparse1(x[[1]])
  if( dp %in% c('<-', '=', '<<-'))  c(x[[2]], get_fun(x[[3]]))
  else if(dp == c('(')) get_fun(x[[2]])
  else if(dp == 'assign') as.list(x[-1])
  else if(dp == 'function') x
  else if(grepl("<<?-",deparse1(x)))c(NA, get_fun(Filter(is.call, x)[[1]]))
}

get_name <- function(y){
  x <- head(get_fun(y), -1)
  if (length(x) > 1 & any(i <- is.na(x))) x <- tail(x,-max(which(i)))
  as.character(x)
}

get_fns <- function(file){
  unlist(lapply(parse(file), get_name))
}

get_fns('ex.R')
 [1] "a"       "b1"      "b2"      "d"       "e"       "f2"     
 [7] "f1"      "j"       "k1"      "k2"      "l2"      "m"