[Rcpp-commits] r1792 - in pkg/Rcpp: . inst/unitTests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jul 6 21:26:22 CEST 2010
Author: romain
Date: 2010-07-06 21:26:21 +0200 (Tue, 06 Jul 2010)
New Revision: 1792
Modified:
pkg/Rcpp/TODO
pkg/Rcpp/inst/unitTests/runit.environments.R
Log:
faster runit.environments
Modified: pkg/Rcpp/TODO
===================================================================
--- pkg/Rcpp/TODO 2010-07-06 16:01:50 UTC (rev 1791)
+++ pkg/Rcpp/TODO 2010-07-06 19:26:21 UTC (rev 1792)
@@ -45,7 +45,7 @@
Syntactic sugar
- o duplicated, unique, count, sum, rep, head, tail, sqrt, log, log10, ln
+ o duplicated, unique, count, sum, head, tail, sqrt, log, log10, ln
o operator%
Modified: pkg/Rcpp/inst/unitTests/runit.environments.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.environments.R 2010-07-06 16:01:50 UTC (rev 1791)
+++ pkg/Rcpp/inst/unitTests/runit.environments.R 2010-07-06 19:26:21 UTC (rev 1792)
@@ -17,12 +17,183 @@
# You should have received a copy of the GNU General Public License
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+.setUp <- function(){
+ if( ! exists( ".rcpp.environments", globalenv() ) ){
+ # definition of all the functions at once
+
+ sugar.functions <- list(
+ "runit_ls" = list(
+ signature(x="environment"),
+ '
+ Rcpp::Environment env(x) ;
+ return env.ls(true) ;
+ ' ),
+ "runit_ls2" = list(
+ signature(x="environment"),
+ '
+ Rcpp::Environment env(x) ;
+ return env.ls(false) ;
+ '
+ ),
+ "runit_get" = list(
+ signature(x="environment", name = "character" ),
+ '
+ Environment env(x) ;
+ return env.get( as<std::string>(name) ) ;
+ '
+ ),
+ "runit_exists" = list(
+ signature(x="environment", name = "character" ),
+ '
+ Environment env(x) ;
+ std::string st = as< std::string >(name) ;
+ return wrap( env.exists( st ) ) ;
+ '
+ ),
+ "runit_assign" =list(
+ signature(x="environment", name = "character", object = "ANY" ),
+ '
+ Environment env(x) ;
+ std::string st = as< std::string>(name) ;
+ return wrap( env.assign(st, object) ) ;
+ '
+ ),
+ "runit_islocked" = list(
+ signature(x="environment" ),
+ '
+ Environment env(x) ;
+ env.assign( "x1", 1 ) ;
+ env.assign( "x2", 10.0 ) ;
+ env.assign( "x3", std::string( "foobar" ) ) ;
+ env.assign( "x4", "foobar" ) ;
+ std::vector< std::string > aa(2) ; aa[0] = "foo" ; aa[1] = "bar" ;
+ env.assign( "x5", aa ) ;
+ return R_NilValue ;
+ '
+ ),
+ "runit_bindingIsActive" = list(
+ signature(x="environment", name = "character" ),
+ '
+ Environment env(x) ;
+ std::string st = as<std::string>(name);
+ return wrap( env.bindingIsActive(st) ) ;
+ '
+ ),
+ "runit_bindingIsLocked" = list(
+ signature(x="environment", name = "character" ),
+ '
+ Environment env(x) ;
+ std::string st = as<std::string>(name) ;
+ return wrap( env.bindingIsLocked(st) ) ;
+ '
+ ),
+ "runit_notanenv" = list(
+ signature(x="ANY"),
+ 'Rcpp::Environment env(x) ;'
+ ),
+ "runit_lockbinding" = list(
+ signature(x="environment", name = "character" ),
+ '
+ Environment env(x) ;
+ std::string st = as<std::string>(name) ;
+ env.lockBinding( st ) ;
+ return R_NilValue ;
+ '
+ ),
+ "runit_unlockbinding" = list(
+ signature(x="environment", name = "character" ),
+ '
+ Environment env(x) ;
+ std::string st = as<std::string>(name) ;
+ env.unlockBinding( st ) ;
+ return R_NilValue ;
+ '
+ ),
+ "runit_globenv" = list(
+ signature(),
+ 'return Rcpp::Environment::global_env(); '
+ ),
+ "runit_emptyenv" = list(
+ signature(),
+ 'return Rcpp::Environment::empty_env(); '
+ ),
+ "runit_baseenv" = list(
+ signature(),
+ 'return Rcpp::Environment::base_env(); '
+ ),
+ "runit_namespace" = list(
+ signature(env = "character" ),
+ '
+ std::string st = as<std::string>(env) ;
+ return Environment::namespace_env(st);
+ '
+ ),
+ "runit_env_SEXP" = list(
+ signature( env = "ANY" ),
+ 'return Environment( env ) ;'
+ ),
+ "runit_env_string" = list(
+ signature( env = "character" ),
+ '
+ std::string st = as<std::string>( env ) ;
+ return Environment( st ) ;
+ '
+ ),
+ "runit_env_int" = list(
+ signature( env = "integer" ),
+ '
+ int pos = as<int>(env) ;
+ return Environment( pos ) ;
+ '
+ ),
+ "runit_parent" = list(
+ signature( env = "environment" ),
+ '
+ return Environment(env).parent() ;
+ '
+ ),
+ "runit_remove" = list(
+ signature( env = "environment", name = "character" ),
+ '
+ bool res = Environment(env).remove( as<std::string>(name) ) ;
+ return wrap( res ) ;
+ '
+ ),
+ "runit_square" = list(
+ signature( env = "environment" ),
+ '
+ Environment e(env) ;
+ List out(3) ;
+ out[0] = e["x"] ;
+ e["y"] = 2 ;
+ out[1] = e["y"] ;
+ e["x"] = "foo";
+ out[2] = e["x"] ;
+ return out ;
+ '
+ ),
+ "runit_Rcpp" = list(
+ signature(),
+ 'return Environment::Rcpp_namespace() ; '
+ ),
+ "runit_child" = list(
+ signature(),
+ '
+ Environment global_env = Environment::global_env() ;
+ return global_env.new_child(false) ;
+ '
+ )
+ )
+ signatures <- lapply( sugar.functions, "[[", 1L )
+ bodies <- lapply( sugar.functions, "[[", 2L )
+ fx <- cxxfunction( signatures, bodies, plugin = "Rcpp" )
+ getDynLib( fx ) # just forcing loading the dll now
+ assign( ".rcpp.environments", fx, globalenv() )
+ }
+}
+
test.environment.ls <- function(){
- funx <- cppfunction(signature(x="environment"), '
- Rcpp::Environment env(x) ;
- return env.ls(true) ;
- ' )
-
+ funx <- .rcpp.environments$runit_ls
e <- new.env( )
e$a <- 1:10
e$b <- "foo"
@@ -31,10 +202,7 @@
checkEquals( funx(asNamespace("Rcpp")), ls(envir=asNamespace("Rcpp"), all = TRUE),
msg = "Environment(namespace)::ls()" )
- funx <- cppfunction(signature(x="environment"), '
- Rcpp::Environment env(x) ;
- return env.ls(false) ;
- ' )
+ funx <- .rcpp.environments$runit_ls2
checkEquals( funx(e), c("a","b"), msg = "Environment::ls(false)" )
checkEquals( funx(asNamespace("Rcpp")), ls(envir=asNamespace("Rcpp"), all = FALSE),
msg = "Environment(namespace)::ls()" )
@@ -42,10 +210,7 @@
}
test.environment.get <- function(){
- funx <- cppfunction(signature(x="environment", name = "character" ), '
- Environment env(x) ;
- return env.get( as<std::string>(name) ) ;
- ' )
+ funx <- .rcpp.environments$runit_get
e <- new.env( )
e$a <- 1:10
@@ -59,12 +224,7 @@
}
test.environment.exists <- function(){
- funx <- cppfunction(signature(x="environment", name = "character" ), '
- Environment env(x) ;
- std::string st = as< std::string >(name) ;
- return wrap( env.exists( st ) ) ;
- ' )
-
+ funx <- .rcpp.environments$runit_exists
e <- new.env( )
e$a <- 1:10
e$b <- "foo"
@@ -76,13 +236,7 @@
}
test.environment.assign <- function(){
-
- funx <- cppfunction(signature(x="environment", name = "character", object = "ANY" ), '
- Environment env(x) ;
- std::string st = as< std::string>(name) ;
- return wrap( env.assign(st, object) ) ;
- ' )
-
+ funx <- .rcpp.environments$runit_assign
e <- new.env( )
checkTrue( funx(e, "a", 1:10 ), msg = "Environment::assign" )
checkTrue( funx(e, "b", Rcpp:::CxxFlags ), msg = "Environment::assign" )
@@ -101,21 +255,10 @@
tryCatch( { funx(e, "a", letters ) ; FALSE}, "error" = function(e) TRUE ),
msg = "cannot assign to locked binding (catch exception)" )
}
-
}
test.environment.isLocked <- function(){
- funx <- cppfunction(signature(x="environment" ), '
- Environment env(x) ;
- env.assign( "x1", 1 ) ;
- env.assign( "x2", 10.0 ) ;
- env.assign( "x3", std::string( "foobar" ) ) ;
- env.assign( "x4", "foobar" ) ;
- std::vector< std::string > aa(2) ; aa[0] = "foo" ; aa[1] = "bar" ;
- env.assign( "x5", aa ) ;
- return R_NilValue ;
- ' )
-
+ funx <- .rcpp.environments$runit_islocked
e <- new.env()
funx(e)
checkEquals( e[["x1"]], 1L , msg = "Environment::assign( int ) " )
@@ -126,13 +269,7 @@
}
test.environment.bindingIsActive <- function(){
-
- funx <- cppfunction(signature(x="environment", name = "character" ), '
- Environment env(x) ;
- std::string st = as<std::string>(name);
- return wrap( env.bindingIsActive(st) ) ;
- ' )
-
+ funx <- .rcpp.environments$runit_bindingIsActive
e <- new.env()
e$a <- 1:10
makeActiveBinding( "b", function(x) 10, e )
@@ -153,13 +290,7 @@
}
test.environment.bindingIsLocked <- function(){
-
- funx <- cppfunction(signature(x="environment", name = "character" ), '
- Environment env(x) ;
- std::string st = as<std::string>(name) ;
- return wrap( env.bindingIsLocked(st) ) ;
- ' )
-
+ funx <- .rcpp.environments$runit_bindingIsLocked
e <- new.env()
e$a <- 1:10
e$b <- letters
@@ -181,7 +312,7 @@
}
test.environment.NotAnEnvironment <- function(){
- funx <- cppfunction(signature(x="ANY"), 'Rcpp::Environment env(x) ;' )
+ funx <- .rcpp.environments$runit_notanenv
checkException( funx( funx ), msg = "not an environment" )
checkException( funx( letters ), msg = "not an environment" )
checkException( funx( NULL ), msg = "not an environment" )
@@ -189,13 +320,7 @@
test.environment.lockBinding <- function(){
- funx <- cppfunction(signature(x="environment", name = "character" ), '
- Environment env(x) ;
- std::string st = as<std::string>(name) ;
- env.lockBinding( st ) ;
- return R_NilValue ;
- ' )
-
+ funx <- .rcpp.environments$runit_lockbinding
e <- new.env()
e$a <- 1:10
e$b <- letters
@@ -215,13 +340,7 @@
}
test.environment.unlockBinding <- function(){
- funx <- cppfunction(signature(x="environment", name = "character" ), '
- Environment env(x) ;
- std::string st = as<std::string>(name) ;
- env.unlockBinding( st ) ;
- return R_NilValue ;
- ' )
-
+ funx <- .rcpp.environments$runit_unlockbinding
e <- new.env()
e$a <- 1:10
e$b <- letters
@@ -242,33 +361,27 @@
}
test.environment.global.env <- function(){
- funx <- cppfunction(signature(),
- 'return Rcpp::Environment::global_env(); ')
+ funx <- .rcpp.environments$runit_globenv
checkEquals( funx(), globalenv(), msg = "REnvironment::global_env" )
}
test.environment.empty.env <- function(){
- funx <- cppfunction(signature(),
- 'return Rcpp::Environment::empty_env(); ' )
+ funx <- .rcpp.environments$runit_emptyenv
checkEquals( funx(), emptyenv(), msg = "REnvironment::empty_env" )
}
test.environment.base.env <- function(){
- funx <- cppfunction(signature(),
- 'return Rcpp::Environment::base_env(); ' )
+ funx <- .rcpp.environments$runit_baseenv
checkEquals( funx(), baseenv(), msg = "REnvironment::base_env" )
}
test.environment.empty.env <- function(){
- funx <- cppfunction(signature(),
- 'return Rcpp::Environment::base_namespace(); ' )
+ funx <- .rcpp.environments$runit_emptyenv
checkEquals( funx(), .BaseNamespaceEnv, msg = "REnvironment::base_namespace" )
}
test.environment.namespace.env <- function(){
- funx <- cppfunction(signature(env = "character" ), '
- std::string st = as<std::string>(env) ;
- return Environment::namespace_env(st); ' )
+ funx <- .rcpp.environments$runit_namespace
checkEquals( funx("Rcpp"), asNamespace("Rcpp"), msg = "REnvironment::base_namespace" )
can.demangle <- Rcpp:::capabilities()[["demangling"]]
@@ -284,7 +397,7 @@
}
test.environment.constructor.SEXP <- function(){
- funx <- cppfunction(signature( env = "ANY" ), 'return Environment( env ) ;' )
+ funx <- .rcpp.environments$runit_env_SEXP
checkEquals( funx( globalenv() ), globalenv(), msg = "Environment( environment ) - 1" )
checkEquals( funx( baseenv() ), baseenv(), msg = "Environment( environment ) - 2" )
checkEquals( funx( asNamespace("Rcpp") ), asNamespace("Rcpp"), msg = "Environment( environment ) - 3" )
@@ -297,10 +410,7 @@
}
test.environment.constructor.stdstring <- function(){
- funx <- cppfunction(signature( env = "character" ), '
- std::string st = as<std::string>( env ) ;
- return Environment( st ) ; ' )
-
+ funx <- .rcpp.environments$runit_env_string
checkEquals( funx( ".GlobalEnv" ), globalenv(), msg = "Environment( std::string ) - 1" )
checkEquals( funx( "package:base" ), baseenv(), msg = "Environment( std::string ) - 2" )
checkEquals( funx( "package:Rcpp" ), as.environment("package:Rcpp") ,
@@ -309,20 +419,14 @@
}
test.environment.constructor.int <- function(){
- funx <- cppfunction(signature( env = "integer" ), '
- int pos = as<int>(env) ;
- return Environment( pos ) ;' )
+ funx <- .rcpp.environments$runit_env_int
for( i in 1:length(search())){
checkEquals( funx(i), as.environment(i), msg = sprintf("Environment(int) - %d", i) )
}
}
test.environment.remove <- function(){
- funx <- cppfunction(signature( env = "environment", name = "character" ), '
- bool res = Environment(env).remove( as<std::string>(name) ) ;
- return wrap( res ) ;
- ' )
-
+ funx <- .rcpp.environments$runit_remove
e <- new.env( )
e$a <- 1
e$b <- 2
@@ -336,9 +440,7 @@
}
test.environment.parent <- function(){
- funx <- cppfunction(signature( env = "environment" ), '
- return Environment(env).parent() ;
- ' )
+ funx <- .rcpp.environments$runit_parent
e <- new.env( parent = emptyenv() )
f <- new.env( parent = e )
@@ -348,18 +450,7 @@
}
test.environment.square <- function(){
-
- funx <- cppfunction(signature( env = "environment" ), '
- Environment e(env) ;
- List out(3) ;
- out[0] = e["x"] ;
- e["y"] = 2 ;
- out[1] = e["y"] ;
- e["x"] = "foo";
- out[2] = e["x"] ;
- return out ;
- ' )
-
+ funx <- .rcpp.environments$runit_square
env <- new.env( )
env[["x"]] <- 10L
checkEquals( funx(env), list( 10L, 2L, "foo") )
@@ -367,17 +458,12 @@
}
test.environment.Rcpp <- function(){
- funx <- cppfunction(signature(), '
- return Environment::Rcpp_namespace() ;
- ' )
+ funx <- .rcpp.environments$runit_Rcpp
checkEquals( funx(), asNamespace("Rcpp") , msg = "cached Rcpp namespace" )
}
test.environment.child <- function(){
- funx <- cppfunction(signature(), '
- Environment global_env = Environment::global_env() ;
- return global_env.new_child(false) ;
- ' )
+ funx <- .rcpp.environments$runit_child
checkEquals( parent.env(funx()), globalenv(),
msg = "" )
}
More information about the Rcpp-commits
mailing list