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

[noreply at r-forge.r-project.org]

Author: romain
Date: 2010-02-14 20:20:01 +0100 (Sun, 14 Feb 2010)
New Revision: 677

Modified:
   pkg/inst/ChangeLog
   pkg/inst/unitTests/runit.Function.R
   pkg/src/Rcpp/Language.h
Log:
allow unary_call(Function) and binary_call(Function) + examples

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2010-02-14 18:22:43 UTC (rev 676)
+++ pkg/inst/ChangeLog	2010-02-14 19:20:01 UTC (rev 677)
@@ -1,3 +1,8 @@
+2010-02-14  Romain Francois <romain at r-enthusiasts.com>
+
+	* src/Rcpp/Language.h: accepting Function in unary_call and 
+	binary_call to support STL algorithms using R functions.
+
 2010-02-14  Dirk Eddelbuettel  <edd at debian.org>
 
 	* DESCRIPTION: Release 0.7.7

Modified: pkg/inst/unitTests/runit.Function.R
===================================================================
--- pkg/inst/unitTests/runit.Function.R	2010-02-14 18:22:43 UTC (rev 676)
+++ pkg/inst/unitTests/runit.Function.R	2010-02-14 19:20:01 UTC (rev 677)
@@ -62,3 +62,50 @@
 		msg = "Function::environment( special) : exception" )
 }
 
+test.Function.unary.call <- function(){
+	
+	funx <- cfunction(signature(y = "list" ), '
+	Function len( "length" ) ;
+	List x(y) ;
+	IntegerVector output( x.size() ) ;
+	std::transform( 
+		x.begin(), x.end(), 
+		output.begin(),
+		unary_call<IntegerVector,int>(len)
+		) ;
+	return output ;
+	', Rcpp = TRUE, verbose = FALSE, includes = "using namespace Rcpp;" )
+	
+	checkEquals( 
+		funx( lapply( 1:10, function(n) seq(from=n, to = 0 ) ) ), 
+		2:11 , 
+		msg = "unary_call(Fcuntion)" )
+	
+}
+
+test.Function.binary.call <- function(){
+	
+	funx <- cfunction(signature(x1 = "list", x2 = "integer" ), '
+	Function pmin( "pmin" ) ;
+	List list(x1) ;
+	IntegerVector vec(x2) ;
+	List output( list.size() ) ;
+	std::transform( 
+		list.begin(), list.end(),
+		vec.begin(), 
+		output.begin(),
+		binary_call<IntegerVector,int,IntegerVector>(pmin)
+		) ;
+	return output ;
+	', Rcpp = TRUE, verbose = FALSE, includes = "using namespace Rcpp;" )
+	
+	data <- lapply( 1:10, function(n) seq(from=n, to = 0 ) )
+	res <- funx( data , rep(5L,10) )
+	expected <- lapply( data, pmin, 5 )
+	
+	checkEquals( res, expected, 
+		msg = "binary_call(Function)" )
+	
+}
+
+

Modified: pkg/src/Rcpp/Language.h
===================================================================
--- pkg/src/Rcpp/Language.h	2010-02-14 18:22:43 UTC (rev 676)
+++ pkg/src/Rcpp/Language.h	2010-02-14 19:20:01 UTC (rev 677)
@@ -172,6 +172,7 @@
 public:
 	unary_call( Language call_ ) : call(call_), proxy(call_,1) {}
 	unary_call( Language call_, int index ) : call(call_), proxy(call_,index){}
+	unary_call( Function fun ) : call( fun, R_NilValue), proxy(call,1) {}
 	
 	OUT operator()( const T& object ){
 		proxy = object ;
@@ -188,6 +189,7 @@
 public:
 	binary_call( Language call_ ) : call(call_), proxy1(call_,1), proxy2(call_,2) {}
 	binary_call( Language call_, int index1, int index2 ) : call(call_), proxy1(call_,index1), proxy2(call_,index2){}
+	binary_call( Function fun) : call(fun, R_NilValue, R_NilValue), proxy1(call,1), proxy2(call,2){}
 	
 	OUT operator()( const T1& o1, const T2& o2 ){
 		proxy1 = o1 ;