[Rcpp-commits] r1788 - pkg/Rcpp/inst/unitTests

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Tue Jul 6 00:16:27 CEST 2010


Author: edd
Date: 2010-07-06 00:16:27 +0200 (Tue, 06 Jul 2010)
New Revision: 1788

Modified:
   pkg/Rcpp/inst/unitTests/runit.GenericVector.R
Log:
converted to 'one cxxfunction call of lists of sigs and bodies' scheme


Modified: pkg/Rcpp/inst/unitTests/runit.GenericVector.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.GenericVector.R	2010-07-05 21:54:52 UTC (rev 1787)
+++ pkg/Rcpp/inst/unitTests/runit.GenericVector.R	2010-07-05 22:16:27 UTC (rev 1788)
@@ -17,168 +17,224 @@
 # 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() {
+    tests <- ".rcpp.List"
+    if( ! exists(tests, globalenv() )) {
+        ## definition of all the functions at once
+        f <- list("ctor"=list(
+                  signature(),
+                  'List x(10) ;
+	           for( int i=0; i<10; i++) x[i] = Rf_ScalarInteger( i * 2)  ;
+	           return x ;')
+
+                  ,"template_"=list(
+                   signature(),
+                   'List x(4) ;
+	            x[0] = "foo"  ;
+	            x[1] = 10 ;
+	            x[2] = 10.2 ;
+	            x[3] = false;
+	            return x ;')
+
+                  ,"VECSXP_"=list(
+                   signature(vec = "list" ),
+                   'List x(vec) ;
+                    return x ;')
+
+                  ,"matrix_indexing_1"=list(
+                   signature(x = "character" ),
+                   'GenericVector m(x) ;
+		    GenericVector out(4) ;
+		    for( size_t i=0 ; i<4; i++){
+		        out[i] = m(i,i) ;
+		    }
+		    return out ;')
+
+                  ,"matrix_indexing_2"=list(
+                   signature(x = "integer" ),
+                   'GenericVector m(x) ;
+		    for(size_t i=0 ; i<4; i++){
+		        m(i,i) = "foo" ;
+		    }
+		    return m ; ')
+
+                  ,"Dimension_constructor_1"=list(
+                   signature(),
+                   'return List( Dimension( 5 ) ) ;')
+
+                  ,"Dimension_constructor_2"=list(
+                   signature(),
+                   'return List( Dimension( 5, 5 ) );')
+
+                  ,"Dimension_constructor_3"=list(
+                   signature(),
+                   ' return List( Dimension( 2, 3, 4) ) ;')
+
+                  ,"iterator_"=list(
+                   signature(x = "list", g = "function" ),
+                   'Function fun(g) ;
+		    List input(x) ;
+		    List output( input.size() ) ;
+		    std::transform( input.begin(), input.end(), output.begin(), fun ) ;
+		    output.names() = input.names() ;
+		    return output ; ')
+
+                  ,"name_indexing"=list(
+                   signature(x = "data.frame"),
+                   'List df(x) ;
+	            IntegerVector df_x = df["x"] ;
+	            int res = std::accumulate( df_x.begin(), df_x.end(), 0 ) ;
+	            return wrap(res); ')
+
+                  ,"push_back"=list(
+                   signature(x = "list"),
+                   'List list(x) ;
+	            list.push_back( 10 ) ;
+	            list.push_back( "bar", "foo" ) ;
+	            return list ;
+	           ')
+
+                  ,"push_front"=list(
+                   signature(x = "list"),
+                   'List list(x) ;
+	            list.push_front( 10 ) ;
+	            list.push_front( "bar", "foo" ) ;
+	            return list ; ')
+
+                  ,"erase"=list(
+                   signature(x = "list"),
+                   'List list(x) ;
+	            list.erase( list.begin() ) ;
+	            return list ; ')
+
+                  ,"erase_range"=list(
+                   signature(x = "list"),
+	           'List list(x) ;
+	            list.erase( 0, 1 ) ;
+	            return list ; ')
+
+                  ,"implicit_push_back"=list(
+                   signature(),
+                   'List list ;
+                    list["foo"] = 10 ;
+                    list["bar" ] = "foobar" ;
+                    return list ;
+                   ')
+
+                  )
+
+        g <- list("initializer_list"=list(
+                  signature(),
+                  'SEXP x0 = PROTECT( Rf_ScalarInteger( 0 ) ) ;
+		   SEXP x1 = PROTECT( Rf_ScalarInteger( 1 ) ) ;
+		   SEXP x2 = PROTECT( Rf_ScalarInteger( 2 ) ) ;
+		   List x = { x0, x1, x2} ;
+		   UNPROTECT(3) ;
+		   return x ;')
+
+                  )
+
+	if (Rcpp:::capabilities()[["initializer lists"]]) {
+            f <- c(f,g)
+        }
+
+        signatures <- lapply(f, "[[", 1L)
+        bodies <- lapply(f, "[[", 2L)
+        fun <- cxxfunction(signatures, bodies,
+                           plugin = "Rcpp", includes = "using namespace std;",
+                           cxxargs = ifelse(Rcpp:::capabilities()[["initializer lists"]],"-std=c++0x",""))
+        getDynLib( fun ) # just forcing loading the dll now
+        assign( tests, fun, globalenv() )
+    }
+}
+
+
 test.List <- function(){
-	funx <- cppfunction(signature(), '
-	List x(10) ;
-	for( int i=0; i<10; i++) x[i] = Rf_ScalarInteger( i * 2)  ;
-	return x ;')
-	checkEquals( funx(), as.list( 2*0:9), msg = "GenericVector" )
+    fun <- .rcpp.List$ctor
+    checkEquals( fun(), as.list( 2*0:9), msg = "GenericVector" )
 }
 
 test.List.template <- function(){
-	funx <- cppfunction(signature(), '
-	List x(4) ;
-	x[0] = "foo"  ;
-	x[1] = 10 ;
-	x[2] = 10.2 ;
-	x[3] = false; 
-	return x ;')
-	checkEquals( funx(), 
-		list( "foo", 10L, 10.2, FALSE), 
-		msg = "GenericVector" )
+    fun <- .rcpp.List$template_
+    checkEquals(fun(), list( "foo", 10L, 10.2, FALSE), msg = "GenericVector" )
 }
 
 test.List.VECSXP <- function(){
-	funx <- cppfunction(signature(vec = "list" ), '
-	List x(vec) ;
-	return x ;' )
-	checkEquals( funx(list(1,2)), list(1,2), msg = "GenericVector( VECSXP) " )
+    fun <- .rcpp.List$VECSXP_
+    checkEquals( fun(list(1,2)), list(1,2), msg = "GenericVector( VECSXP) " )
 }
 
-test.List.initializer.list <- function(){
-	if( Rcpp:::capabilities()[["initializer lists"]] ){
-		funx <- cppfunction(signature(), '
-		SEXP x0 = PROTECT( Rf_ScalarInteger( 0 ) ) ;
-		SEXP x1 = PROTECT( Rf_ScalarInteger( 1 ) ) ;
-		SEXP x2 = PROTECT( Rf_ScalarInteger( 2 ) ) ;
-		List x = { x0, x1, x2} ;
-		UNPROTECT(3) ;
-		return x ;', cxxargs="-std=c++0x" )
-		checkEquals( funx(), as.list(0:2), msg = "List( initializer list) " )
-	}
+if( Rcpp:::capabilities()[["initializer lists"]] ){
+    test.List.initializer.list <- function(){
+        fun <- .rcpp.List$initializer_list
+        checkEquals( fun(), as.list(0:2), msg = "List( initializer list) " )
+    }
 }
 
 test.List.matrix.indexing <- function(){
-	
-	funx <- cppfunction(signature(x = "character" ), '
-		GenericVector m(x) ;
-		GenericVector out(4) ;
-		for( size_t i=0 ; i<4; i++){
-			out[i] = m(i,i) ;
-		}
-		return out ;
-	'  )
-	
-	# a matrix of integer vectors
-	x <- structure( lapply( 1:16, function(x) seq.int(x) ), dim = c( 4, 4) )
-	checkEquals( funx(x), diag(x), msg = "matrix indexing" )
-	
-	funx <- cppfunction(signature(x = "integer" ), '
-		GenericVector m(x) ;
-		for( size_t i=0 ; i<4; i++){
-			m(i,i) = "foo" ;
-		}
-		return m ;
-	'  )
-	checkEquals( diag(funx(x)), rep(list("foo"), 4) , 
-		msg = "matrix indexing lhs" )
-	
-	# drop dimensions
-	dim(x) <- NULL
-	checkException( funx(x) , msg = "not a matrix" )
+    fun <- .rcpp.List$matrix_indexing_1
+    ## a matrix of integer vectors
+    x <- structure( lapply( 1:16, function(x) seq.int(x) ), dim = c( 4, 4) )
+    checkEquals( fun(x), diag(x), msg = "matrix indexing 1" )
+
+    fun <- .rcpp.List$matrix_indexing_2
+    checkEquals(diag(fun(x)), rep(list("foo"), 4) , msg = "matrix indexing lhs" )
+
+    ## drop dimensions
+    dim(x) <- NULL
+    checkException( fun(x) , msg = "not a matrix" )
 }
 
 test.List.Dimension.constructor <- function(){
+    fun <- .rcpp.List$Dimension_constructor_1
+    checkEquals(fun(),
+		rep(list(NULL),5) ,
+                msg = "List( Dimension(5))" )
 
-	funx <- cppfunction(signature(), '
-		return List( Dimension( 5 ) ) ;
-	'  )
-	checkEquals( funx(), 
-		rep(list(NULL),5) , 
-		msg = "List( Dimension(5))" )
-	
-	funx <- cppfunction(signature(), '
-		return List( Dimension( 5, 5 ) ) ;
-	'  )
-	checkEquals( funx(), 
+    fun <- .rcpp.List$Dimension_constructor_2
+    checkEquals(fun(),
 		structure( rep( list(NULL), 25), dim = c(5,5) ),
 		msg = "List( Dimension(5,5))" )
-	
-	funx <- cppfunction(signature(), '
-		return List( Dimension( 2, 3, 4) ) ;
-	'  )
-	checkEquals( funx(), 
-		array( rep(list(NULL)), dim = c(2,3,4) ) , 
+
+    fun <- .rcpp.List$Dimension_constructor_3
+    checkEquals(fun(),
+		array( rep(list(NULL)), dim = c(2,3,4) ) ,
 		msg = "List( Dimension(2,3,4))" )
 }
 
-test.List.iterator <- function(){
-	
-	cpp_lapply <- cppfunction(signature(x = "list", g = "function" ), '
-		Function fun(g) ;
-		List input(x) ;
-		List output( input.size() ) ;
-		std::transform( input.begin(), input.end(), output.begin(), fun ) ;
-		output.names() = input.names() ;
-		return output ;
-	'  )
-	
-	data <- list( x = letters, y = LETTERS, z = 1:4 )
-	checkEquals( 
-		cpp_lapply( data, length ), 
-		list( x = 26L, y = 26L, z = 4L), 
+test.List.iterator <- function() {
+    fun <- .rcpp.List$iterator_
+    data <- list( x = letters, y = LETTERS, z = 1:4 )
+    checkEquals(fun( data, length ),
+		list( x = 26L, y = 26L, z = 4L),
 		msg = "c++ version of lapply" )
-	
 }
 
 test.List.name.indexing <- function(){
-	
-	funx <- cppfunction( signature(x = "data.frame"), 
-	'
-	List df(x) ;
-	IntegerVector df_x = df["x"] ;
-	int res = std::accumulate( df_x.begin(), df_x.end(), 0 ) ;
-	return wrap(res);
-	' )
-	d <- data.frame( x = 1:10, y = letters[1:10] )
-	checkEquals( funx( d ), sum(1:10), msg = "List names based indexing" )
+    fun <- .rcpp.List$name_indexing
+    d <- data.frame( x = 1:10, y = letters[1:10] )
+    checkEquals( fun( d ), sum(1:10), msg = "List names based indexing" )
 }
 
 test.List.push.back <- function(){
-	
-	funx <- cppfunction( signature(x = "list"), 
-	'
-	List list(x) ;
-	list.push_back( 10 ) ;
-	list.push_back( "bar", "foo" ) ;
-	return list ;
-	' )
-	d <- list( x = 1:10, y = letters[1:10] )
-	res <- funx( d )
-	checkEquals( res,
-		list( x = 1:10, y = letters[1:10], 10L, foo = "bar" ), 
+    fun <- .rcpp.List$push_back
+    d <- list( x = 1:10, y = letters[1:10] )
+    checkEquals(fun( d ),
+		list( x = 1:10, y = letters[1:10], 10L, foo = "bar" ),
 		msg = "List.push_back" )
 }
 
 test.List.push.front <- function(){
-	
-	funx <- cppfunction( signature(x = "list"), 
-	'
-	List list(x) ;
-	list.push_front( 10 ) ;
-	list.push_front( "bar", "foo" ) ;
-	return list ;
-	' )
-	d <- list( x = 1:10, y = letters[1:10] )
-	res <- funx( d )
-	checkEquals( res,
-		list( foo = "bar", 10L, x = 1:10, y = letters[1:10] ), 
+    fun <- .rcpp.List$push_front
+    d <- list( x = 1:10, y = letters[1:10] )
+    checkEquals(fun(d),
+		list( foo = "bar", 10L, x = 1:10, y = letters[1:10] ),
 		msg = "List.push_front" )
 }
 
 # test.List.insert <- function(){
-# 	
-# 	funx <- cppfunction( signature(x = "list"), 
+#
+# 	funx <- cppfunction( signature(x = "list"),
 # 	'
 # 	List list(x) ;
 # 	list.insert( list.begin(), 10 ) ;
@@ -188,50 +244,29 @@
 # 	d <- list( x = 1:10, y = letters[1:10] )
 # 	res <- funx( d )
 # 	checkEquals( res,
-# 		list( 10L, x = 1:10, y = letters[1:10], foo = "bar" ), 
+# 		list( 10L, x = 1:10, y = letters[1:10], foo = "bar" ),
 # 		msg = "List.insert" )
 # }
 
 test.List.erase <- function(){
-	
-	funx <- cppfunction( signature(x = "list"), 
-	'
-	List list(x) ;
-	list.erase( list.begin() ) ;
-	return list ;
-	' )
-	d <- list( x = 1:10, y = letters[1:10] )
-	res <- funx( d )
-	checkEquals( res,
-		list( y = letters[1:10] ), 
+    fun <- .rcpp.List$erase
+    d <- list( x = 1:10, y = letters[1:10] )
+    checkEquals(fun(d),
+		list( y = letters[1:10] ),
 		msg = "List.erase" )
 }
 
 test.List.erase.range <- function(){
-	
-	funx <- cppfunction( signature(x = "list"), 
-	'
-	List list(x) ;
-	list.erase( 0, 1 ) ;
-	return list ;
-	' )
-	d <- list( x = 1:10, y = letters[1:10], z = 1:10 )
-	res <- funx( d )
-	checkEquals( res,
-		list( z = 1:10 ), 
+    fun <- .rcpp.List$erase_range
+    d <- list( x = 1:10, y = letters[1:10], z = 1:10 )
+    checkEquals(fun(d),
+		list( z = 1:10 ),
 		msg = "List.erase (range version)" )
 }
 
 test.List.implicit.push.back <- function(){
-
-        funx <- cppfunction( signature(),
-        '
-        List list ;
-        list["foo"] = 10 ;
-        list["bar" ] = "foobar" ;
-        return list ;
-        ' )
-        checkEquals( funx(), list( foo = 10, bar = "foobar" ), msg = "List implicit push back" )
+    fun <- .rcpp.List$implicit_push_back
+    checkEquals( fun(), list( foo = 10, bar = "foobar" ), msg = "List implicit push back" )
 }
 
 



More information about the Rcpp-commits mailing list