How to have an active binding know if it's called as a function?

Question

I would like something like that:

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

I use f here, should work with any function

In the example above f returns 1 and f(4) returns sqrt(4). In my real use case the naked f (not f()) will return a function object, so the workaround proposed by Michal cannot be used as is.

I use + here for simplicity, but it might be any function or none, including NSE functions like quote(), so for instance quote(f) and quote(f()) should not have their input changed by the solution.

I tried to play with the sys.calls() but couldn't get anything robust.

Answers using low level code are welcome too, who knows maybe dark magic can help.

These won't be called at the top level so if you cannot make the above work but can get the following to work for instance that's good too, and in practice it won't be the .GlobalEnv so if you can make it work in another environment that's good too.

identity(f + f)
#> 2

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

If you have solutions that just get me closer you might post them, for instance if your solution works only if f and f() are not used in the same call it's still useful to me.

---

Since I was asked about the real context here it is, but solving the above is all I ask.

• My package {boomer} provides a way to curry a function f by modifying its environment and populating its new enclosure with shims of every function f calls, we say that we rig f.
• These shims print the calls and their outputs, but behave the same apart from side effects, so f and rigged f are expected to return the same
• However if the shims are returned, or if their body is manipulated by f, the output will be unexpected
• By treating shim and shim() differently I avoid the more obvious corner cases, shim() will show side effects, and shim would return the original function.

The issue is here and package in action is showed here

And also tbh I'm generally curious about if it's possible.

Aeriel

This definitely looks like a good candidate for github.com/romainfrancois/evil.R ;-) Will you only do addition with 'f' or should it work any any context? – Wrinkly

The context has to be general, in my use case f is a curried function, if it's called, I want the curried function to be called, if it's returned, or asked for body(f) for example, I want my original uncurried f to be used. I see how it might be used for evil, but I promise to use it for good ;). – Aeriel

Can you supplement your question with a bigger picture what are you trying to achieve? – Wrinkly

I tried Michal, but it's quite complex, I don't know if it will help! – Aeriel

Would a solution within another function call work? E.g., f2(f + f(4)) . Otherwise, it would seem like you would need to be able to parse the original expression before being evaluated. – Psychologism

It might yes, and maybe I'd override { to be this f2 function since these calls would form the body of another function in my use case. – Aeriel

Answer 1

One trick that comes to my mind is to create two nested environments, one being a parent of another and each having a different definition of f. Then you can evaluate f + f() in the "child" and it will work:

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

Cater

This is a good idea, and I should improve my example because in my case the naked f would also return a function, so this trick as is wouldn't fly – Aeriel

OK, I see. I get some sense of your goal from your edits. It seems to require the same symbol to universally evaluate to two different things depending on the context... I don't see it possible, but will be happy if convinced otherwise. – Wrinkly

Answer 2

Here is a method using the walkast package. It essentially replaces function objects named f with 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
          }
        }
      )
    )
  )
}

Expressions need to be wrapped in evaluate.

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

evaluate(f + f)
#> 2

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

Fatally

Thanks for introducing me to this cool package, I can't really use this solution but other solutions don't get me there either so enjoy the bounty! – Aeriel

Answer 3

Although this doesn't follow the exact approach you suggested (somehow finding out how the function was called), this trick using attributes and a custom S3 class can be used to produce the intended behaviour:

# 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

Soppy

+ is not the only function that might be called unfortunately (question now edited to make it clear). Maybe I could shim all functions so they recognize fancy functions provided as arguments, but I'm not sure how I'd make it work with NSE. Moreover the call might be just f, in which case no S3 method will help. Good idea though and upvoted, thanks. – Aeriel

@Moody_Mudskipper you can extend this to other operations (-, /, etc.). Or are there special cases? if it should work NSE this clarification would need to be added to the question. – Reckoner

My example uses + for the sake of simplicity but a general solution would work with any function or no function at all. – Aeriel

Answer 4

As you mentioned that solution of type f2(f + f(1)) might work, I decided to contribute this not very elegant but "seems to be working" solution.

TL;DR: convert code to string, parse, get more data with getParseData(), replace target variable depending on if it is a simple symbol or called as function, evaluate new code string in proper environment.

Notes:

• This is currently designed to replace only one target variable at a time. If multiple replacements are needed, consecutive calls to replace_in_code() should do the trick.
• If you want to only replace target when it is called as function, tweaks in is_target and replacement definition should be fairly straightforward.
• I decided to evaluate new code string in a most simple way, but maybe more complicated environment creation might be needed in your case.

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

^{Created on 2021-06-27 by the reprex package (v2.0.0)}

Organization

Answer 5

TL; DR If this is not too much of an assumption, then I would decide it through humility f = f () And with using a parameter with a default value. It seems to me that this is the simplest solution of the proposed ones.

I know for sure that this is easily achieved in JS, since there is such a method on an object as 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)

But unfortunately in R, as far as I know, there is no such method.

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

Reckoner

Thanks for the effort Daniil but I can't use f() rather than f – Aeriel

@Moody_Mudskipper, may I know the reason why you prefer one over the other? I ask because it seemed to me that you weren’t satisfied with other answers. Is not it? – Reckoner

@Moody_Mudskipper, I'll try to search the sources for R ... But if the answer has already been found, tell me – Reckoner

The precise use case is complex and is explained as much as I could at the end of my question. In short I don't write the expressions myself, so I can't replace naked f with f() as it would mess with non standard evaluation (e.g quote(f) would become quote(f()) , and would require f() without arguments to be special, which is many times unacceptable. At the moment no answer is satisfactory, though some might help, so feel free to keep looking :). I think active bindings are probably the way. I have a draft solution myself that I'll post but it's not perfect either. – Aeriel

OK, Thanks, I see – Reckoner

Answer 6

I would suggest using R6 package for this problem. An example:

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

For more details on R6.

Seismism

Thanks, this seems similar to Daniil's answer, unfortunately I can't use this, for the same reason. – Aeriel

Answer 7

In the interest of the idea of f2(f + f(4)), here is an attempt:

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

Psychologism

Out of curiosity, did you have any comments about this? – Psychologism