[Rcpp-devel] [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:
/**
_______________________________________________
Rcpp-commits mailing list
Rcpp-commits at lists.r-forge.r-project.org
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-commits
More information about the Rcpp-devel
mailing list