[Rcpp-commits] r246 - in pkg: inst/doc inst/unitTests man src src/Rcpp

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Thu Dec 31 11:59:31 CET 2009


Author: romain
Date: 2009-12-31 11:59:31 +0100 (Thu, 31 Dec 2009)
New Revision: 246

Modified:
   pkg/inst/doc/Rcpp-unitTests.R
   pkg/inst/unitTests/runit.environments.R
   pkg/man/RcppUnitTests.Rd
   pkg/src/Environment.cpp
   pkg/src/Rcpp/Environment.h
Log:
some more methods in Rcpp::Environment

Modified: pkg/inst/doc/Rcpp-unitTests.R
===================================================================
--- pkg/inst/doc/Rcpp-unitTests.R	2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/inst/doc/Rcpp-unitTests.R	2009-12-31 10:59:31 UTC (rev 246)
@@ -24,5 +24,8 @@
 tests <- runTestSuite(testSuite)
 printHTMLProtocol(tests, fileName="Rcpp-unitTests.html" )
 printTextProtocol(tests, fileName="Rcpp-unitTests.txt" )
+if( file.exists( "/tmp" ) ){
+	file.copy( "Rcpp-unitTests.txt", "/tmp", overwrite = TRUE )
+	file.copy( "Rcpp-unitTests.html", "/tmp", overwrite = TRUE )
+}
 
-

Modified: pkg/inst/unitTests/runit.environments.R
===================================================================
--- pkg/inst/unitTests/runit.environments.R	2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/inst/unitTests/runit.environments.R	2009-12-31 10:59:31 UTC (rev 246)
@@ -94,8 +94,11 @@
 	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" )
+	lockBinding( "a", e )
+	checkTrue( 
+		tryCatch( { funx(e, "a", letters ) ; FALSE}, "Rcpp::Environment::binding_is_locked" = function(e) TRUE ), 
+		msg = "cannot assign to locked binding (catch exception)" )
+
 }
 
 test.environment.isLocked <- function(){
@@ -121,10 +124,12 @@
 	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" )
+	checkTrue( 
+		tryCatch( { funx(e, "xx" ) ; FALSE}, "Rcpp::Environment::no_such_binding" = function(e) TRUE ), 
+		msg = "Environment::bindingIsActive(no binding) -> exception)" )
 	
 }
 
@@ -143,7 +148,9 @@
 	
 	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" )
+	checkTrue( 
+		tryCatch( { funx(e, "xx" ) ; FALSE}, "Rcpp::Environment::no_such_binding" = function(e) TRUE ), 
+		msg = "Environment::bindingIsLocked(no binding) -> exception)" )
 	
 }
 
@@ -156,3 +163,80 @@
 	checkException( funx( NULL ), msg = "not an environment" )
 }
 
+
+test.environment.lockBinding <- function(){
+	funx <- cfunction(signature(x="environment", name = "character" ), '
+	Rcpp::Environment env(x) ;
+	std::string st = Rcpp::RObject(name).asStdString() ;
+	env.lockBinding( st ) ;
+	return R_NilValue ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	e <- new.env()
+	e$a <- 1:10
+	e$b <- letters
+	funx(e, "b")
+	checkTrue( bindingIsLocked("b", e ), msg = "Environment::lockBinding()" )
+	checkTrue( 
+		tryCatch( { funx(e, "xx" ) ; FALSE}, "Rcpp::Environment::no_such_binding" = function(e) TRUE ), 
+		msg = "Environment::lockBinding(no binding) -> exception)" )
+	
+}
+
+test.environment.unlockBinding <- function(){
+	funx <- cfunction(signature(x="environment", name = "character" ), '
+	Rcpp::Environment env(x) ;
+	std::string st = Rcpp::RObject(name).asStdString() ;
+	env.unlockBinding( st ) ;
+	return R_NilValue ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	e <- new.env()
+	e$a <- 1:10
+	e$b <- letters
+	lockBinding( "b", e )
+	funx(e, "b")
+	checkTrue( !bindingIsLocked("b", e ), msg = "Environment::lockBinding()" )
+	checkTrue( 
+		tryCatch( { funx(e, "xx" ) ; FALSE}, "Rcpp::Environment::no_such_binding" = function(e) TRUE ), 
+		msg = "Environment::unlockBinding(no binding) -> exception)" )
+	
+}
+
+test.environment.global.env <- function(){
+	funx <- cfunction(signature(), 
+	'return Rcpp::Environment::global_env(); ', Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx(), globalenv(), msg = "REnvironment::global_env" )
+}
+
+test.environment.empty.env <- function(){
+	funx <- cfunction(signature(), 
+	'return Rcpp::Environment::empty_env(); ', Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx(), emptyenv(), msg = "REnvironment::empty_env" )
+}
+
+test.environment.base.env <- function(){
+	funx <- cfunction(signature(), 
+	'return Rcpp::Environment::base_env(); ', Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx(), baseenv(), msg = "REnvironment::base_env" )
+}
+
+test.environment.empty.env <- function(){
+	funx <- cfunction(signature(), 
+	'return Rcpp::Environment::base_namespace(); ', Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx(), .BaseNamespaceEnv, msg = "REnvironment::base_namespace" )
+}
+
+test.environment.namespace.env <- function(){
+	funx <- cfunction(signature(env = "character" ),  '
+	std::string st = Rcpp::RObject(env).asStdString() ;
+	return Rcpp::Environment::namespace_env(st); ', Rcpp=TRUE, verbose=FALSE)
+	checkEquals( funx("Rcpp"), asNamespace("Rcpp"), msg = "REnvironment::base_namespace" )
+	checkTrue( 
+		tryCatch( { funx("----" ) ; FALSE}, "Rcpp::Environment::no_such_namespace" = function(e) TRUE ), 
+		msg = "Environment::namespace_env(no namespace) -> exception)" )
+	
+}
+
+
+

Modified: pkg/man/RcppUnitTests.Rd
===================================================================
--- pkg/man/RcppUnitTests.Rd	2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/man/RcppUnitTests.Rd	2009-12-31 10:59:31 UTC (rev 246)
@@ -16,7 +16,7 @@
 }
 
 \details{
-\Sexpr[echo=FALSE,results=text]{ Rcpp:::dumpUnitTestReport() }
+\Sexpr[echo=FALSE,results=text]{ if(exists("dumpUnitTestReport", asNamespace("Rcpp"))) Rcpp:::dumpUnitTestReport() else ""}
 }
 
 \examples{

Modified: pkg/src/Environment.cpp
===================================================================
--- pkg/src/Environment.cpp	2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/src/Environment.cpp	2009-12-31 10:59:31 UTC (rev 246)
@@ -32,13 +32,20 @@
     struct safeAssign_s *s = (struct safeAssign_s*) data;
     Rf_defineVar(s->sym, s->val, s->rho);
 }
-	
-	
+
+struct safeFindNamespace_s {
+    SEXP sym, val ;
+};
+static void safeFindNamespace(void *data) {
+    struct safeFindNamespace_s *s = (struct safeFindNamespace_s*) data;
+    s->val = R_FindNamespace(s->sym);
+}
+
+
     Environment::Environment( SEXP m_sexp = R_GlobalEnv) : RObject::RObject(m_sexp){
 	if( TYPEOF(m_sexp) != ENVSXP ){
 	    throw std::runtime_error( "not an environment" ) ;
 	}
-	is_user_database = IS_USER_DATABASE(m_sexp) ;
     }
 	
     Environment::~Environment(){
@@ -46,7 +53,7 @@
     }
 	
     SEXP Environment::ls( bool all = true) const {
-	if( is_user_database ){
+	if( is_user_database() ){
 	    R_ObjectTable *tb = (R_ObjectTable*)
 		R_ExternalPtrAddr(HASHTAB(m_sexp));
 	    return tb->objects(tb) ;
@@ -74,9 +81,14 @@
     	return res != R_UnboundValue ;
     }
     
-    bool Environment::assign( const std::string& name, SEXP x = R_NilValue) const{
+    bool Environment::assign( const std::string& name, SEXP x = R_NilValue) const throw(binding_is_locked){
+    	if( exists( name) && bindingIsLocked(name) ) throw binding_is_locked(name) ;
+    	
     	/* borrowed from JRI, we cannot just use defineVar since it might 
     	   crash on locked bindings */
+    	   
+    	/* TODO: we need to modify R_ToplevelExec so that it does not print 
+    	         the error message as it currently does*/
     	struct safeAssign_s s;
     	s.sym = Rf_install( name.c_str() ) ;
     	if( !s.sym || s.sym == R_NilValue ) return false ;
@@ -87,18 +99,86 @@
     }
     
     bool Environment::isLocked() const{
-    	return static_cast<bool>(R_EnvironmentIsLocked(m_sexp));
+    	return 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::bindingIsActive(const std::string& name) const throw(no_such_binding) {
+    	if( !exists( name) ) throw no_such_binding(name) ;
+    	return 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)) ;
+    bool Environment::bindingIsLocked(const std::string& name) const throw(no_such_binding) {
+    	if( !exists( name) ) throw no_such_binding(name) ;
+    	return R_BindingIsLocked(Rf_install(name.c_str()), m_sexp) ;
     }
     
+    void Environment::lock( bool bindings = false ) {
+    	R_LockEnvironment( m_sexp, bindings ? TRUE: FALSE ) ;
+    }
+    
+    void Environment::lockBinding(const std::string& name) throw(no_such_binding) {
+    	if( !exists( name) ) throw no_such_binding(name) ;
+    	R_LockBinding( Rf_install( name.c_str() ), m_sexp ); 
+    }
+    
+    void Environment::unlockBinding(const std::string& name) throw(no_such_binding) {
+    	if( !exists( name) ) throw no_such_binding(name) ;
+    	R_unLockBinding( Rf_install( name.c_str() ), m_sexp );
+    }
+    
+    bool Environment::is_user_database() const {
+    	return OBJECT(m_sexp) && Rf_inherits(m_sexp, "UserDefinedDatabase") ;
+    }
+    
+    /* static */
+    
+    Environment Environment::global_env() throw() {
+    	return Environment(R_GlobalEnv) ;
+    }
+    
+    Environment Environment::empty_env() throw() {
+    	return Environment(R_GlobalEnv) ;
+    }
+    
+    Environment Environment::base_env() throw(){
+    	return Environment(R_BaseEnv) ;
+    }
+    
+    Environment Environment::base_namespace() throw() {
+    	return Environment(R_BaseNamespace) ;
+    }
+    
+    Environment Environment::namespace_env(const std::string& package) throw(no_such_namespace) {
+    	struct safeFindNamespace_s s;
+    	s.sym = Rf_mkString( package.c_str() ) ;
+    	if( !s.sym || s.sym == R_NilValue || !R_ToplevelExec(safeFindNamespace, (void*) &s) ){
+    		throw no_such_namespace(package) ;
+    	}
+    	return s.val ;
+    }
+    
+    /* exceptions */
+    
+    Environment::no_such_binding::no_such_binding(const std::string& binding) :
+    	message( "no such binding : '" + binding + "'" ) {}
+    const char* Environment::no_such_binding::what() const throw(){
+    	return message.c_str() ;
+    }
+    Environment::no_such_binding::~no_such_binding() throw() {}
+    
+    Environment::binding_is_locked::binding_is_locked(const std::string& binding) : 
+    	message("binding is locked : '" + binding + "'" ) {}
+    const char* Environment::binding_is_locked::what() const throw(){
+    	return message.c_str() ;
+    }
+    Environment::binding_is_locked::~binding_is_locked() throw() {}
+    
+    Environment::no_such_namespace::no_such_namespace(const std::string& package) : 
+    	message("no such namespace : '" + package + "'" ) {}
+    const char* Environment::no_such_namespace::what() const throw(){
+    	return message.c_str() ;
+    }
+    Environment::no_such_namespace::~no_such_namespace() throw() {}
+    
 } // namespace Rcpp
 

Modified: pkg/src/Rcpp/Environment.h
===================================================================
--- pkg/src/Rcpp/Environment.h	2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/src/Rcpp/Environment.h	2009-12-31 10:59:31 UTC (rev 246)
@@ -25,14 +25,77 @@
 #include <RcppCommon.h>
 #include <Rcpp/RObject.h>
 
-#define IS_USER_DATABASE(rho)  OBJECT((rho)) && Rf_inherits((rho), "UserDefinedDatabase")
-
 namespace Rcpp{ 
 
 class Environment: public RObject{
 public:
-	
+
+   /**
+     * Exception thrown when attempting to perform an operation on 
+     * a binding and there is no such binding
+     */
+    class no_such_binding: public std::exception{
+    	public:
+    		/**
+    		 * @param binding name of the binding
+    		 */
+    		no_such_binding( const std::string& binding) ;
+    		
+    		/**
+    		 * The message: no such binding : '{binding}' 
+    		 */
+    		const char* what() const throw();
+    		
+    		~no_such_binding() throw() ;
+    		
+    	private:
+    		std::string message ;
+    } ;
+    
     /**
+     * Exception thrown when attempting to assign a value to a binding 
+     * that is locked
+     */
+    class binding_is_locked: public std::exception{
+    	public:
+    		/**
+    		 * @param binding name of the binding
+    		 */
+    		binding_is_locked( const std::string& binding) ;
+    		
+    		/**
+    		 * The message: binding is locked : '{binding}' 
+    		 */
+    		const char* what() const throw() ;
+    		
+    		~binding_is_locked() throw() ;
+    	private:
+    		std::string message ;
+    } ;
+    
+    /**
+     * Exception thrown when attempting to get a namespace that does
+     * not exist
+     */
+    class no_such_namespace: public std::exception{
+    	public:
+    		/**
+    		 * @param package name of the package
+    		 */
+    		no_such_namespace( const std::string& package) ;
+    		
+    		/**
+    		 * The message: no such namespace : '{package}' 
+    		 */
+    		const char* what() const throw() ;
+    		
+    		~no_such_namespace() throw() ;
+    	private:
+    		std::string message ;
+    } ;
+    
+    
+    /**
      * wraps the given environment
      *
      * if the SEXP is not an environment, and exception is thrown
@@ -80,8 +143,11 @@
      * @param x object to assign
      *
      * @return true if the assign was successfull
+     * see ?bindingIsLocked
+     *
+     * @throw binding_is_locked if the binding is locked
      */
-    bool assign( const std::string& name, SEXP x ) const ;
+    bool assign( const std::string& name, SEXP x ) const throw(binding_is_locked) ;
     
     /**
      * @return true if this environment is locked
@@ -90,12 +156,40 @@
     bool isLocked() const ;
     
     /**
+     * locks this environment. See ?lockEnvironment
+     *
+     * @param bindings also lock the bindings of this environment ?
+     */
+    void lock(bool bindings) ;
+    
+    /* maybe we should have a separate class, e.g. Binding to deal
+       with the 4 below functions ? */
+    
+    /**
+     * Locks the given binding in the environment. 
+     * see ?bindingIsLocked
+     *
+     * @throw no_such_binding if there is no such binding in this environment
+     */
+    void lockBinding(const std::string& name) throw(no_such_binding);
+    
+    /**
+     * unlocks the given binding
+     * see ?bindingIsLocked
+     *
+     * @throw no_such_binding if there is no such binding in this environment
+     */
+    void unlockBinding(const std::string& name) throw(no_such_binding) ;
+    
+    /**
      * @param name name of a potential binding
      *
      * @return true if the binding is locked in this environment
      * see ?bindingIsLocked
+     *
+     * @throw no_such_binding if there is no such binding in this environment
      */
-    bool bindingIsLocked(const std::string& name) const ;
+    bool bindingIsLocked(const std::string& name) const throw(no_such_binding) ;
     
     /**
      *
@@ -103,16 +197,44 @@
      * 
      * @return true if the binding is active in this environment
      * see ?bindingIsActive
+     *
+     * @throw no_such_binding if there is no such binding in this environment
      */
-    bool bindingIsActive(const std::string& name) const ;
+    bool bindingIsActive(const std::string& name) const throw(no_such_binding) ;
     
-protected:
-	
+    /** 
+     * Indicates if this is a user defined database.
+     */
+    bool is_user_database() const ;
+    
     /**
-     * we cache whether this environment is a user defined database
-     * or a standard environment
+     * @return the global environment. See ?globalenv
      */
-    bool is_user_database ;
+    static Environment global_env() throw() ;
+    
+    /**
+     * @return The empty environment. See ?emptyenv
+     */
+    static Environment empty_env() throw() ;
+    
+    /**
+     * @return the base environment. See ?baseenv
+     */
+    static Environment base_env() throw() ;
+    
+    /**
+     * @return the base namespace. See ?baseenv
+     */
+    static Environment base_namespace() throw() ;
+    
+    /**
+     * @param name the name of the package of which we want the namespace
+     *
+     * @return the namespace of the package
+     *
+     * @throw no_such_namespace 
+     */
+    static Environment namespace_env(const std::string& ) throw(no_such_namespace) ;
 };
 
 } // namespace Rcpp



More information about the Rcpp-commits mailing list