From 8efb2b2db70aeb836a1dd4419595ede46246aff4 Mon Sep 17 00:00:00 2001
From: Lionel Henry <lionel.hry@gmail.com>
Date: Fri, 20 Feb 2015 12:12:27 +0100
Subject: [PATCH] Add Function constructors to perform function-lookup in an
 environment or in a namespace

---
 ChangeLog                       |  5 +++++
 inst/include/Rcpp/Function.h    | 31 +++++++++++++++++++++++++++----
 inst/unitTests/cpp/Function.cpp | 11 ++++++++++-
 inst/unitTests/runit.Function.R | 21 ++++++++++++++++++++-
 4 files changed, 62 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index ce3149b89..cf117a2d4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2015-02-20  Lionel Henry  <lionel.hry@gmail.com>
+
+        * inst/include/Rcpp/Function.h New Function constructors that will
+        perform function-lookup in an environment or in a namespace.
+
 2015-02-19  Dirk Eddelbuettel  <edd@debian.org>
 
         * DESCRIPTION: Bump Version: and Date:
diff --git a/inst/include/Rcpp/Function.h b/inst/include/Rcpp/Function.h
index 11024757a..1ee9a90b5 100644
--- a/inst/include/Rcpp/Function.h
+++ b/inst/include/Rcpp/Function.h
@@ -49,14 +49,29 @@ namespace Rcpp{
         }
 
         /**
-         * Finds a function, searching from the global environment
+         * Finds a function. By default, searches from the global environment
          *
          * @param name name of the function
+         * @param env an environment where to search the function
+         * @param ns name of the namespace in which to search the function
          */
         Function_Impl(const std::string& name) {
-            SEXP nameSym = Rf_install( name.c_str() );	// cannot be gc()'ed  once in symbol table
-            Shield<SEXP> x( Rf_findFun( nameSym, R_GlobalEnv ) ) ;
-            Storage::set__(x) ;
+            get_function(name, R_GlobalEnv);
+        }
+
+        Function_Impl(const std::string& name, const SEXP env) {
+            if (!Rf_isEnvironment(env)) {
+                stop("env is not an environment");
+            }
+            get_function(name, env);
+        }
+
+        Function_Impl(const std::string& name, const std::string& ns) {
+            Shield<SEXP> env(Rf_findVarInFrame(R_NamespaceRegistry, Rf_install(ns.c_str())));
+            if (env == R_UnboundValue) {
+                stop("there is no namespace called \"%s\"", ns);
+            }
+            get_function(name, env);
         }
 
         SEXP operator()() const {
@@ -84,6 +99,14 @@ namespace Rcpp{
         }
 
         void update(SEXP){}
+
+
+    private:
+        void get_function(const std::string& name, const SEXP env) {
+            SEXP nameSym = Rf_install( name.c_str() );	// cannot be gc()'ed  once in symbol table
+            Shield<SEXP> x( Rf_findFun( nameSym, env ) ) ;
+            Storage::set__(x) ;
+        }
     };
 
     typedef Function_Impl<PreserveStorage> Function ;
diff --git a/inst/unitTests/cpp/Function.cpp b/inst/unitTests/cpp/Function.cpp
index 7a2767d39..3b4ba34fc 100644
--- a/inst/unitTests/cpp/Function.cpp
+++ b/inst/unitTests/cpp/Function.cpp
@@ -25,6 +25,16 @@ using namespace Rcpp ;
 // [[Rcpp::export]]
 Function function_(SEXP x){ return Function(x) ; }
 
+// [[Rcpp::export]]
+Function function_cons_env(std::string x, SEXP env) {
+    return Function(x, env);
+}
+
+// [[Rcpp::export]]
+Function function_cons_ns(std::string x, std::string ns) {
+    return Function(x, ns);
+}
+
 // [[Rcpp::export]]
 NumericVector function_variadic(Function sort, NumericVector y){
     return sort( y, Named("decreasing", true) ) ;
@@ -66,4 +76,3 @@ Function function_namespace_env(){
     Function fun = ns[".asSparse"] ;  // accesses a non-exported function
     return fun;
 }
-
diff --git a/inst/unitTests/runit.Function.R b/inst/unitTests/runit.Function.R
index 029fecce1..e1065e9fe 100644
--- a/inst/unitTests/runit.Function.R
+++ b/inst/unitTests/runit.Function.R
@@ -27,7 +27,7 @@ if (.runThisTest) {
     test.Function <- function(){
         checkEquals( function_( rnorm ), rnorm, msg = "Function( CLOSXP )" )
         checkEquals( function_( is.function ), is.function, msg = "Pairlist( BUILTINSXP )" )
-        
+
         checkException( function_(1:10), msg = "Function( INTSXP) " )
         checkException( function_(TRUE), msg = "Function( LGLSXP )" )
         checkException( function_(1.3), msg = "Function( REALSXP) " )
@@ -68,4 +68,23 @@ if (.runThisTest) {
         checkEquals( stats:::.asSparse, exportedfunc, msg = "namespace_env(Function)" )
     }
 
+    test.Function.cons.env <- function() {
+        parent_env <- new.env()
+        parent_env$fun_parent <- rbinom
+        child_env <- new.env(parent = parent_env)
+        child_env$fun_child <- rnorm
+
+        checkEquals(rnorm, function_cons_env("fun_child", child_env), msg = "env-lookup constructor")
+        checkEquals(rbinom, function_cons_env("fun_parent", child_env), msg = "env-lookup constructor: search function in parent environments")
+        checkException(function_cons_env("fun_child", parent_env), msg = "env-lookup constructor: fail when function not found")
+    }
+
+    test.Function.cons.ns <- function() {
+        checkEquals(Rcpp::sourceCpp, function_cons_ns("sourceCpp", "Rcpp"), msg = "namespace-lookup constructor")
+        checkException(function_cons_ns("sourceCpp", "Rcppp"), msg = "namespace-lookup constructor: fail when ns does not exist")
+        checkException(function_cons_ns("sourceCppp", "Rcpp"), msg = "namespace-lookup constructor: fail when function not found")
+    }
+
+    # also check function is found in parent env
+
 }