match.fun provide error with functions defined inside functions - r

Question

I get error when try to apply match.fun to the functions define within other functions.
x <- matrix(rnorm(10*100), nrow=100) # data sample
descStats <- function(x, stats = c("n", "min", "max", "srange", "mean", "median", "sd")) {
n <- function(x, ...) sum(!is.na(x), ...)
srange <- function(x, ...) max(x, ...) - min(x, ...)
fun <- function(x) {
result <- vapply(stats, function(z) match.fun(z)(x, na.rm=TRUE), FUN.VALUE=numeric(1))
}
if (is.vector(x)) {
result <- fun(x)
}
if (is.matrix(x) || is.data.frame(x)) {
result <- t(apply(x, 2, fun))
}
return(result)
}
descStats(x)
## Error in get(as.character(FUN), mode = "function", envir = envir) :
## object 'n' of mode 'function' was not found
If I define n and srange outside of descStats function it works fine.
n <- function(x, ...) sum(!is.na(x), ...)
srange <- function(x, ...) max(x, ...) - min(x, ...)
descStats2 <- function(x, stats = c("n", "min", "max", "srange", "mean", "median", "sd")) {
fun <- function(x) {
result <- vapply(stats, function(z) match.fun(z)(x, na.rm=TRUE), FUN.VALUE=numeric(1))
}
if (is.vector(x)) {
result <- fun(x)
}
if (is.matrix(x) || is.data.frame(x)) {
result <- t(apply(x, 2, fun))
}
return(result)
}
descStats2(x)
## n min max srange mean median sd
## [1,] 100 -2.303839 2.629366 4.933205 0.03711611 0.14566523 1.0367947
## [2,] 100 -1.968923 2.169382 4.138305 -0.03917503 0.02239458 0.9048509
## [3,] 100 -2.365891 2.424077 4.789968 -0.08012138 -0.23515910 1.0438133
## [4,] 100 -2.740045 2.127787 4.867832 0.03978241 0.15363449 0.9778891
## [5,] 100 -1.598295 2.603525 4.201820 0.23796616 0.16376239 1.0428915
## [6,] 100 -1.550385 1.684155 3.234540 -0.11114479 -0.09264598 0.8260126
## [7,] 100 -2.438641 3.268796 5.707438 0.02948100 -0.05594740 1.0481331
## [8,] 100 -1.716407 2.795340 4.511747 0.22463606 0.16296613 0.9555129
## [9,] 100 -2.359165 1.975993 4.335158 -0.33321888 -0.17580933 0.9784788
## [10,] 100 -2.139267 2.838986 4.978253 0.15540182 0.07803265 1.0149671
Another way it's use eval(call(FUN, args)). For instance.
descStats3 <- function(x, stats = c("n", "min", "max", "srange", "mean", "median", "sd")) {
n <- function(x, ...) sum(!is.na(x), ...)
srange <- function(x, ...) max(x, ...) - min(x, ...)
fun <- function(x) {
result <- vapply(stats, function(z) eval(call(z, x, na.rm=TRUE)), FUN.VALUE=numeric(1))
}
if (is.vector(x)) {
result <- fun(x)
}
if (is.matrix(x) || is.data.frame(x)) {
result <- t(apply(x, 2, fun))
}
return(result)
}
descStats3(x)
## n min max srange mean median sd
## [1,] 100 -2.303839 2.629366 4.933205 0.03711611 0.14566523 1.0367947
## [2,] 100 -1.968923 2.169382 4.138305 -0.03917503 0.02239458 0.9048509
## [3,] 100 -2.365891 2.424077 4.789968 -0.08012138 -0.23515910 1.0438133
## [4,] 100 -2.740045 2.127787 4.867832 0.03978241 0.15363449 0.9778891
## [5,] 100 -1.598295 2.603525 4.201820 0.23796616 0.16376239 1.0428915
## [6,] 100 -1.550385 1.684155 3.234540 -0.11114479 -0.09264598 0.8260126
## [7,] 100 -2.438641 3.268796 5.707438 0.02948100 -0.05594740 1.0481331
## [8,] 100 -1.716407 2.795340 4.511747 0.22463606 0.16296613 0.9555129
## [9,] 100 -2.359165 1.975993 4.335158 -0.33321888 -0.17580933 0.9784788
## [10,] 100 -2.139267 2.838986 4.978253 0.15540182 0.07803265 1.0149671
identical(descStats2(x), descStats3(x))
## [1] TRUE
Why descStats not work?

Answer 1

It's relatively easy (and illustrative) to write your own version of match.fun. I've called my function fget to indicate that it's a version of get specifically designed for functions, and hence obeys the regular scoping rules for functions. (If you're not sure what they are, think about this code: c <- 10; c(c, 5))
#' Find a function with specified name.
#'
#' #param name length one character vector giving name
#' #param env environment to start search in.
#' #examples
#' c <- 10
#' fget("c")
fget <- function(name, env = parent.frame()) {
if (identical(env, emptyenv())) {
stop("Could not find function called ", name, call. = FALSE)
}
if (exists(name, env, inherits = FALSE) && is.function(env[[name]])) {
env[[name]]
} else {
fget(name, parent.env(env))
}
}
The implementation is as a straightforward recursive function: the base case is the emptyenv(), the eventual ancestor of every environment, and for each environment along the stack of parents, we check to see that both an object called name exists, and that it is a function.
It works in the simple test case provided by #nograpes because the environment defaults to the calling environment:
fun <- function(x) {
n <- sum
fget('n')(x)
}
fun(10)
# [1] 10

Answer 2

it is a scope problem. Looking in the code of match.fun you get the answer.
match.fun scope is the envir <- parent.frame(2)
get scope is in the envir = as.environment(-1) = parent.frame(1)
I think we can't pass the envir as an argument.
One solution is to use get as presented by #nograpes ( unsafe) or to hack match.fun and change
envir <- parent.frame(2) to envir <- parent.frame(1)

Answer 3

For reasons I don't completely understand yet, if you use get instead of match.fun, everything works fine.
x <- matrix(rnorm(10*100), nrow=100) # data sample
descStats <- function(x, stats = c("n", "min", "max", "srange", "mean", "median", "sd")) {
n <- function(x, ...) sum(!is.na(x), ...)
srange <- function(x, ...) max(x, ...) - min(x, ...)
fun <- function(x) {
# get added here.
result <- vapply(stats, function(z) get(z)(x, na.rm=TRUE), FUN.VALUE=numeric(1))
}
if (is.vector(x)) {
result <- fun(x)
}
if (is.matrix(x) || is.data.frame(x)) {
result <- t(apply(x, 2, fun))
}
return(result)
}
descStats(x)