如何让活动绑定知道它是否被称为函数？

Question

我想要这样的东西：

makeActiveBinding("f", function() {
  called_as_a_function <- ... # <- insert answer here
  if(called_as_a_function) { 
    sqrt
  } else {
    1
  }
}, .GlobalEnv)

# Expected output

f + f
#> 2

f(4) + f
#> 3

我在这里使用f，应该可以使用任何功能

在上面的示例中，f 返回 1，f(4) 返回 sqrt(4)。在我的实际用例中，裸f（不是f()）将返回一个函数对象，因此不能按原样使用 Michal 提出的解决方法。

为了简单起见，我在这里使用 +，但它可能是任何函数或没有函数，包括像 quote() 这样的 NSE 函数，因此例如 quote(f) 和 quote(f()) 不应该让他们的输入被解决方案更改。

我尝试使用sys.calls()，但无法获得任何强大的功能。

也欢迎使用低级代码的答案，谁知道也许黑魔法会有所帮助。

这些不会在顶层调用，所以如果你不能进行上述工作，但可以让以下工作，例如，这也很好，实际上它不会是 .GlobalEnv 所以如果你可以让它在另一个也很好的环境中工作。

identity(f + f)
#> 2

identity(f(4) + f)
#> 3

如果您有让我更接近的解决方案，您可以发布它们，例如，如果您的解决方案仅在 f 和 f() 未在同一个呼叫中使用时才有效，它对我仍然有用。

---

因为我被问到这里的真实情况，但我只要求解决上述问题。

• 我的包 {boomer} 提供了一种对函数 f 进行柯里化的方法，方法是修改其环境并使用 f 调用的每个函数的垫片填充其新外壳，我们说我们 rig f。李>
• 这些填充程序会打印调用及其输出，但除了副作用外表现相同，因此 f 和操纵的 f 预计返回相同
• 但是，如果垫片被退回，或者它们的主体被 f 操纵，输出将是意外的
• 通过区别对待shim 和shim()，我避免了更明显的极端情况，shim() 将显示副作用，shim 将返回原始函数。

问题是here，正在运行的包显示为here

而且我通常很好奇这是否可能。

Answer 1

我想到的一个技巧是创建两个嵌套环境，一个是另一个的父级，每个都有不同的 f 定义。然后你可以在“孩子”中评估f + f()，它会起作用：

e1 <- new.env()
e2 <- new.env(parent = e1)
assign("f", sqrt, envir = e1)
assign("f", 1, envir = e2)
eval(expression(f + f(4)), envir=e2)
#> [1] 3

Answer 2

虽然这不遵循您建议的确切方法（以某种方式找出函数的调用方式），但使用属性和自定义 S3 类的这个技巧可用于产生预期的行为：

# Define a function and give it a special class
f <- function(x) sqrt(x)
class(f) <- "fancy"

# Add a 'value' attribute
attr(f, "value") <- 1

# Now define addition for our class to use the 'value' attribute
`+.fancy` <- function(x, y) {
  
  x_val <- if ("fancy" %in% class(x)) attr(x, "value") else x
  y_val <- if ("fancy" %in% class(y)) attr(y, "value") else y
  
  x_val + y_val
  
}

# Seems to work as intended
f + f
#> [1] 2

f(4) + 1
#> [1] 3

Answer 3

正如您提到的 f2(f + f(1)) 类型的解决方案可能有效，我决定贡献这个不是很优雅但“似乎有效”的解决方案。

TL;DR：将代码转换为字符串，解析，使用getParseData() 获取更多数据，根据目标变量是简单符号还是作为函数调用来替换目标变量，评估新的代码字符串适当的环境。

注意事项：

• 目前设计为一次仅替换一个目标变量。如果需要多次替换，连续调用 replace_in_code() 应该可以解决问题。
• 如果您只想在 target 作为函数调用时替换它，那么在 is_target 和 replacement 定义中的调整应该相当简单。
• 我决定以最简单的方式评估新的代码字符串，但在您的情况下可能需要更复杂的环境创建。

replace_and_eval <- function(code_block, target_var, value, fun) {
  # Replace variable `target_var` with `value` variable if it is a simple
  # symbol and with `fun` if it is called as function
  code <- replace_in_code(
    code_string = substitute(code_block),
    target_var = target_var,
    value_var = "value",
    fun_var = "fun"
  )

  # Evaluate in current environment
  eval(parse(text = code))
}

replace_in_code <- function(code_string, target_var, value_var, fun_var) {
  # Parse code string
  parsed <- parse(text = code_string, keep.source = TRUE)
  ast <- utils::getParseData(parsed)

  # Find any relevant tokens
  is_target <- (ast[["text"]] == target_var) &
    (ast[["token"]] %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"))

  if (!any(is_target)) {
    return(code_string)
  }

  # Prepare data for replacements
  target_ast <- ast[is_target, ]
  replacement <- ifelse(target_ast[["token"]] == "SYMBOL", value_var, fun_var)
  line1 <- target_ast[["line1"]]
  col1 <- target_ast[["col1"]]
  col2 <- target_ast[["col2"]]

  # Get actual lines of code which should be updated ("srcfile" is a source of
  # a parsed code)
  lines <- getSrcLines(attr(parsed, "srcfile"), 1, max(ast[["line2"]]))

  # Make replacements from the end to respect updating `lines` in place
  for (i in order(line1, col1, decreasing = TRUE)) {
    l_num <- line1[i]
    l <- lines[l_num]
    lines[l_num] <- paste0(
      substr(l, 0, col1[i] - 1),
      replacement[i],
      substr(l, col2[i] + 1, nchar(l))
    )
  }

  paste0(lines, collapse = "\n")
}

# Tests
replace_and_eval(quote(f + f(4)), "f", value = 10, fun = sqrt)
#> [1] 12
replace_and_eval(quote(list(f, f(4), f)), "f", value = stats::dnorm, fun = sqrt)
#> [[1]]
#> function (x, mean = 0, sd = 1, log = FALSE) 
#> .Call(C_dnorm, x, mean, sd, log)
#> <bytecode: 0x56161ac8c098>
#> <environment: namespace:stats>
#> 
#> [[2]]
#> [1] 2
#> 
#> [[3]]
#> function (x, mean = 0, sd = 1, log = FALSE) 
#> .Call(C_dnorm, x, mean, sd, log)
#> <bytecode: 0x56161ac8c098>
#> <environment: namespace:stats>

## Bizarre target variable
replace_and_eval(quote(data.frame + data.frame(4)), "data.frame", 10, sqrt)
#> [1] 12

## Multiline code block with "tricky" code
replace_and_eval(
  code_block = quote({
    # Should print 1
    print(nchar("f"))
    # There is also f in comment, but it won't be quoted
    print(f)
    print(f(4))
  }),
  target_var = "f",
  value = "Hello",
  fun = sqrt
)
#> [1] 1
#> [1] "Hello"
#> [1] 2

## Evaluation is in proper environment
fun <- function(value = 1000, fun = -1000) {
  replace_and_eval(
    code_block = quote(list(f, f(4))),
    target_var = "f",
    value = stats::dnorm,
    fun = sqrt
  )
}
fun()
#> [[1]]
#> function (x, mean = 0, sd = 1, log = FALSE) 
#> .Call(C_dnorm, x, mean, sd, log)
#> <bytecode: 0x56161ac8c098>
#> <environment: namespace:stats>
#> 
#> [[2]]
#> [1] 2

^{由reprex package (v2.0.0) 于 2021 年 6 月 27 日创建}

Answer 4

这是使用walkast 包的方法。它实质上将名为 f 的函数对象替换为 f_fun。

f_fun <- sqrt
f <- 1

evaluate <- function(expr) {
  expr <- substitute(expr)
  
  eval(
    walkast::walk_ast(
      expr,
      walkast::make_visitor(
        hd = function(fun) {
          if (all.names(fun) == "f") {
            f_fun
          } else {
            fun
          }
        }
      )
    )
  )
}

表达式需要包裹在evaluate中。

evaluate(f + f(4))
#> 3

evaluate(f + f)
#> 2

evaluate(f(f + f(9)) + f(4))
#> 4

Answer 5

TL; DR 如果这不是一个太多的假设，那么我会通过谦虚来决定它f = f () 并使用具有默认值的参数。在我看来，这是建议中最简单的解决方案。

我确信这在 JS 中很容易实现，因为对象上有 valueOf 这样的方法。

function f(n){
  return Math.sqrt(n)
}

f.valueOf = f.toString = function valueOf(){return 1}


console.log('f(4) =', f(4))
console.log('f + f(4) =', f + f(4))
console.log('f =', f)
console.log('f + f =', f + f)

但不幸的是，在 R 中，据我所知，没有这样的方法。

default_value <- function(){ 
  1 # I use the function instead value
}

# just for an example of change f = 1 to f = 1 + size
increment <- function(size = 1){
  temp <- default_value() + size
  default_value <<- function(){
    temp # use closure instead infinite recursion
  }  
  0 # without effect in calulations (if it's necessary)
}

f2 <- sqrt

f1 <- function(value = default_value()){
  if (value != default_value()){
    result <- f2(value) # sqrt
  } else {
    result <- value     # 1
  }
}

#--------------------------------------------------------------

assign("f", f1) # just as alias if it's necessary

eval(f() + f(4))
#> 3

eval(f() + f())
#> 2

eval(f(f() + f(9)) + f(4))
#> 4

eval(increment(1) + f(f() + f(9)) + f(4)) # sqrt(5) == 2.236068
#> 4.236068

eval(f())
#> 2

eval(increment(-1) + f(f() + f(9)) + f(4)) # use decrement
#> 4

Answer 6

我建议使用R6 包来解决这个问题。一个例子：

SQRT <- R6::R6Class(
  classname = "SQRT",
  public = list(
    f = function(x = NULL) {
      if(is.null(x)){
        return(1)
      } else {
        return(sqrt(x))
      }
    }
  )
);

# create a new instence
env <- SQRT$new();

# call public methods 
env$f() + env$f(4);
#> [1] 3

env$f() + env$f(16) + env$f(4)
#> [1] 7

更多详情请关注R6。

Answer 7

为了f2(f + f(4))的想法，这里尝试一下：

f = function() {
  print("this is a weird function")
}

main = function(x) {
  xsub = substitute(x)

  ## short circuit if user entered main(f)
  if (is.name(xsub) && as.character(xsub) == 'f') 
    return (f)
  else
    xsub = parser(xsub)

  eval(xsub, list(f = 1))
}

parser = function(e) {
  ## largely taken from data.table:::replace_dot_alias
  if (is.call(e)) {
    if (e[[1L]] == 'f') e[[1L]] = quote(sqrt)
    ## recursively parse deeper into expression for more replacement
    for (i in seq_along(e)[-1L]) if (!is.null(e[[i]])) e[[i]] = parser(e[[i]])
  } 
  return(e)
}

main(f)
#> function() {
#>   print("this is a weird function")
#> }
main(f(4) + f)
#> [1] 3
main(f + f)
#> [1] 2