[Rcpp-commits] r241 - in pkg: . inst inst/unitTests src src/Rcpp

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Wed Dec 30 20:33:52 CET 2009


Author: romain
Date: 2009-12-30 20:33:52 +0100 (Wed, 30 Dec 2009)
New Revision: 241

Modified:
   pkg/cleanup
   pkg/inst/ChangeLog
   pkg/inst/unitTests/runit.environments.R
   pkg/src/Environment.cpp
   pkg/src/Rcpp/Environment.h
Log:
more complete support for Rcpp::Environment

Modified: pkg/cleanup
===================================================================
--- pkg/cleanup	2009-12-30 18:49:15 UTC (rev 240)
+++ pkg/cleanup	2009-12-30 19:33:52 UTC (rev 241)
@@ -5,6 +5,7 @@
 	inst/lib/Rcpp/* \
 	inst/lib/libRcpp.so inst/lib/Rcpp*.h inst/lib/libRcpp.a \
 	inst/doc/*.cpp inst/doc/*.hpp \
+	inst/doc/*.out \
 	inst/doc/*.Rd inst/doc/*.aux inst/doc/*.log inst/doc/*.tex \
 	inst/doc/latex/*.aux inst/doc/latex/*.log \
 	inst/doc/auto \

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2009-12-30 18:49:15 UTC (rev 240)
+++ pkg/inst/ChangeLog	2009-12-30 19:33:52 UTC (rev 241)
@@ -1,6 +1,7 @@
 2009-12-30  Romain Francois <francoisromain at free.fr>
 
-	* src/Rcpp/Environment.h : added minimal support for environment
+	* src/Rcpp/Environment.h : added support for environment through the
+	Rcpp::Environment class
 	
 	* src/Environment.cpp: idem
 	

Modified: pkg/inst/unitTests/runit.environments.R
===================================================================
--- pkg/inst/unitTests/runit.environments.R	2009-12-30 18:49:15 UTC (rev 240)
+++ pkg/inst/unitTests/runit.environments.R	2009-12-30 19:33:52 UTC (rev 241)
@@ -45,6 +45,114 @@
 	
 }
 
+test.environment.get <- function(){
+	funx <- cfunction(signature(x="environment", name = "character" ), '
+	Rcpp::Environment env(x) ;
+	return env.get( Rcpp::RObject(name).asStdString() ) ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	e <- new.env( )
+	e$a <- 1:10
+	e$b <- "foo"
+	
+	checkEquals( funx( e, "a" ), e$a, msg = "Environment::get()" )
+	checkEquals( funx( e, "foobar" ), NULL, msg = "Environment::get()" )
+	checkEquals( funx( asNamespace("Rcpp"), "CxxFlags"), Rcpp:::CxxFlags, 
+		msg = "Environment(namespace)::get() " )
+	
+}
 
+test.environment.exists <- function(){
+	funx <- cfunction(signature(x="environment", name = "character" ), '
+	Rcpp::Environment env(x) ;
+	std::string st = Rcpp::RObject(name).asStdString() ;
+	return Rcpp::RObject( env.exists(st) ) ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	e <- new.env( )
+	e$a <- 1:10
+	e$b <- "foo"
+	
+	checkTrue( funx( e, "a" ), msg = "Environment::get()" )
+	checkTrue( !funx( e, "foobar" ), msg = "Environment::get()" )
+	checkTrue( funx( asNamespace("Rcpp"), "CxxFlags"), 
+		msg = "Environment(namespace)::get() " )
+}
 
+test.environment.assign <- function(){
+	
+	funx <- cfunction(signature(x="environment", name = "character", object = "ANY" ), '
+	Rcpp::Environment env(x) ;
+	std::string st = Rcpp::RObject(name).asStdString() ;
+	return Rcpp::RObject( env.assign(st, object) ) ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	e <- new.env( )
+	checkTrue( funx(e, "a", 1:10 ), msg = "Environment::assign" )
+	checkTrue( funx(e, "b", Rcpp:::CxxFlags ), msg = "Environment::assign" )
+	checkEquals( ls(e), c("a", "b"), msg = "Environment::assign, checking names" )
+	checkEquals( e$a, 1:10, msg = "Environment::assign, checking value 1" )
+	checkEquals( e$b, Rcpp:::CxxFlags, msg = "Environment::assign, checking value 2" )
+	
+	lockBinding( "a", e ) 
+	checkTrue( !funx(e, "a", letters ), msg = "Environment::assign and locked bindings" )
+}
 
+test.environment.isLocked <- function(){
+	funx <- cfunction(signature(x="environment" ), '
+	Rcpp::Environment env(x) ;
+	return Rcpp::RObject( env.isLocked() ) ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	e <- new.env()
+	checkTrue( !funx(e), msg = "Environment::isLocked( new.env) -> false" )
+	checkTrue( funx(asNamespace("Rcpp")), msg = "Environment::isLocked( namespace:Rcpp ) -> true" )
+	
+}
+
+test.environment.bindingIsActive <- function(){
+	
+	funx <- cfunction(signature(x="environment", name = "character" ), '
+	Rcpp::Environment env(x) ;
+	std::string st = Rcpp::RObject(name).asStdString() ;
+	return Rcpp::RObject( env.bindingIsActive(st) ) ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	e <- new.env()
+	e$a <- 1:10
+	makeActiveBinding( "b", function(x) 10, e ) 
+	
+	checkTrue( !funx(e, "a" ), msg = "Environment::bindingIsActive( non active ) -> false" )
+	checkTrue( funx(e, "b" ), msg = "Environment::bindingIsActive( active ) -> true" )
+	checkTrue( !funx(e, "xx" ), msg = "Environment::bindingIsActive( no binding ) -> false" )
+	
+}
+
+test.environment.bindingIsLocked <- function(){
+	
+	funx <- cfunction(signature(x="environment", name = "character" ), '
+	Rcpp::Environment env(x) ;
+	std::string st = Rcpp::RObject(name).asStdString() ;
+	return Rcpp::RObject( env.bindingIsLocked(st) ) ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	e <- new.env()
+	e$a <- 1:10
+	e$b <- letters
+	lockBinding( "b", e )
+	
+	checkTrue( !funx(e, "a" ), msg = "Environment::bindingIsActive( non active ) -> false" )
+	checkTrue( funx(e, "b" ), msg = "Environment::bindingIsActive( active ) -> true" )
+	checkTrue( !funx(e, "xx" ), msg = "Environment::bindingIsActive( no binding ) -> false" )
+	
+}
+
+test.environment.NotAnEnvironment <- function(){
+	funx <- cfunction(signature(x="ANY"), 'Rcpp::Environment env(x) ;', 
+		Rcpp=TRUE, verbose=FALSE)
+	checkException( funx( funx ), msg = "not an environment" )
+	checkException( funx( letters ), msg = "not an environment" )
+	checkException( funx( iris ), msg = "not an environment" )
+	checkException( funx( NULL ), msg = "not an environment" )
+}
+

Modified: pkg/src/Environment.cpp
===================================================================
--- pkg/src/Environment.cpp	2009-12-30 18:49:15 UTC (rev 240)
+++ pkg/src/Environment.cpp	2009-12-30 19:33:52 UTC (rev 241)
@@ -23,6 +23,17 @@
 
 namespace Rcpp {
 
+/* this comes from JRI, where it was introduced to cope with cases
+   where bindings are locked */
+struct safeAssign_s {
+    SEXP sym, val, rho;
+};
+static void safeAssign(void *data) {
+    struct safeAssign_s *s = (struct safeAssign_s*) data;
+    Rf_defineVar(s->sym, s->val, s->rho);
+}
+	
+	
     Environment::Environment( SEXP m_sexp = R_GlobalEnv) : RObject::RObject(m_sexp){
 	if( TYPEOF(m_sexp) != ENVSXP ){
 	    throw std::runtime_error( "not an environment" ) ;
@@ -45,6 +56,49 @@
 	}
 	return R_NilValue ;
     }
-	
+    
+    SEXP Environment::get( const std::string& name) const {
+    	SEXP res = Rf_findVarInFrame( m_sexp, Rf_install(name.c_str())  ) ;
+    	
+    	if( res == R_UnboundValue ) return R_NilValue ;
+    	
+    	/* We need to evaluate if it is a promise */
+	if( TYPEOF(res) == PROMSXP){
+    		res = Rf_eval( res, m_sexp ) ;
+    	}
+    	return res ;
+    }
+    
+    bool Environment::exists( const std::string& name) const{
+    	SEXP res = Rf_findVarInFrame( m_sexp, Rf_install(name.c_str())  ) ;
+    	return res != R_UnboundValue ;
+    }
+    
+    bool Environment::assign( const std::string& name, SEXP x = R_NilValue) const{
+    	/* borrowed from JRI, we cannot just use defineVar since it might 
+    	   crash on locked bindings */
+    	struct safeAssign_s s;
+    	s.sym = Rf_install( name.c_str() ) ;
+    	if( !s.sym || s.sym == R_NilValue ) return false ;
+    	
+    	s.rho = m_sexp ;
+    	s.val = x ;
+    	return static_cast<bool>( R_ToplevelExec(safeAssign, (void*) &s) );
+    }
+    
+    bool Environment::isLocked() const{
+    	return static_cast<bool>(R_EnvironmentIsLocked(m_sexp));
+    }
+    
+    bool Environment::bindingIsActive(const std::string& name) const{
+    	if( !exists( name) ) return false ; /* should this be an exception instead ? */
+    	return static_cast<bool>(R_BindingIsActive(Rf_install(name.c_str()), m_sexp)) ;
+    }
+    
+    bool Environment::bindingIsLocked(const std::string& name) const{
+    	if( !exists( name) ) return false ; /* should this be an exception instead ? */
+    	return static_cast<bool>(R_BindingIsLocked(Rf_install(name.c_str()), m_sexp)) ;
+    }
+    
 } // namespace Rcpp
 

Modified: pkg/src/Rcpp/Environment.h
===================================================================
--- pkg/src/Rcpp/Environment.h	2009-12-30 18:49:15 UTC (rev 240)
+++ pkg/src/Rcpp/Environment.h	2009-12-30 19:33:52 UTC (rev 241)
@@ -49,9 +49,63 @@
      * 
      * the same as calling this from R: 
      * > ls( envir = this, all = all )
+     *
+     * @param all same meaning as in ?ls
      */ 
     SEXP ls(bool all) const ;
     
+    /**
+     * Get an object from the environment
+     *
+     * @param name name of the object
+     *
+     * @return a SEXP (possibly R_NilValue)
+     */
+    SEXP get(const std::string& name) const ;
+    
+    /**
+     * Indicates if an object called name exists in the 
+     * environment
+     *
+     * @param name name of the object
+     *
+     * @return true if the object exists in the environment
+     */
+    bool exists( const std::string& name ) const ;
+    
+    /**
+     * Attempts to assign x to name in this environment
+     *
+     * @param name name of the object to assign
+     * @param x object to assign
+     *
+     * @return true if the assign was successfull
+     */
+    bool assign( const std::string& name, SEXP x ) const ;
+    
+    /**
+     * @return true if this environment is locked
+     * see ?environmentIsLocked for details of what this means
+     */
+    bool isLocked() const ;
+    
+    /**
+     * @param name name of a potential binding
+     *
+     * @return true if the binding is locked in this environment
+     * see ?bindingIsLocked
+     */
+    bool bindingIsLocked(const std::string& name) const ;
+    
+    /**
+     *
+     * @param name name of a binding
+     * 
+     * @return true if the binding is active in this environment
+     * see ?bindingIsActive
+     */
+    bool bindingIsActive(const std::string& name) const ;
+    
 protected:
 	
     /**



More information about the Rcpp-commits mailing list