[Rcpp-commits] r1713 - pkg/Rcpp/inst/examples/SugarPerformance

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

Author: romain
Date: 2010-06-24 14:57:22 +0200 (Thu, 24 Jun 2010)
New Revision: 1713

Modified:
   pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R
Log:
rework the code a bit

Modified: pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R
===================================================================
--- pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R	2010-06-24 10:54:10 UTC (rev 1712)
+++ pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R	2010-06-24 12:57:22 UTC (rev 1713)
@@ -2,10 +2,28 @@
 suppressMessages(library(inline))
 suppressMessages(library(Rcpp))
 
-benchmark <- function(start, hand.written, sugar, expr, runs = 500,
-                      data = list( x = runif(1e5),  y = runif(1e5) ),
-                      end = "") {
+benchmark <- function(start = settings$start, 
+                      hand.written = settings$hand.written, 
+                      sugar = settings$sugar, 
+                      expr = settings$expr, 
+                      runs = settings$runs,
+                      data = settings$data,
+                      end = settings$end, 
+                      inc = settings$inc, 
+                      
+                      settings = list( 
+                      		start = "", hand.written = "", 
+                      		sugar = "", expr = NULL, 
+                      		runs = 500, 
+                      		data = NULL , 
+                      		end = "", 
+                      		inc = ""
+                      		)
+                      ) {
 
+expr <- force(expr)
+inc  <- force( inc )
+
 src <- sprintf( '
     unsigned int runs = as<int>(runss);
    	Environment e(env) ;
@@ -63,16 +81,18 @@
 
 	fun <- cxxfunction(signature(runss="integer", expr = "language", env = "environment" ),
 	                   src,
-	                   includes='#include "Timer.h"',
+	                   includes= sprintf( '#include "Timer.h"\n%s', paste( inc, collapse = "\n" ) ),
 	                   plugin="Rcpp",
 	                   settings=settings)
-	fun(runs, expr, environment() )
+	results <- fun(runs, expr, environment() )
+	cat( "-" )
+	list( results = results, runs = runs, expr = deparse(expr) )
 }
 
-res.ifelse <- benchmark( '
+settings.ifelse <- list( start = '
 	NumericVector x = e["x"] ;
 	NumericVector y = e["y"] ;
-', '
+', hand.written = '
 	int n = x.size() ;
 	NumericVector res1( n ) ;
 	double x_ = 0.0 ;
@@ -89,19 +109,41 @@
         }
     }
 
-', '
+', sugar = '
     NumericVector res2 = ifelse( x < y, x*x, -(y*y) ) ;
+', expr = quote(ifelse(x<y, x*x, -(y*y) )), 
+   data = list( x = runif(1e5),  y = runif(1e5) )
+)
+
+settings.sapply <- list( start =  '
+	NumericVector x = e["x"] ;
+	int n = x.size() ;
+
+', hand.written = '
+	NumericVector res1( n ) ;
+	std::transform( x.begin(), x.end(), res1.begin(), square ) ;
+
+', sugar = '
+	NumericVector res2 = sapply( x, square ) ; 
 ',
-	quote(ifelse(x<y, x*x, -(y*y) ))
+	expr = quote(sapply(x,square)),
+	runs = 500,
+	data = list(
+		x = rnorm(1e5) ,
+		square = function(x) x*x
+	), 
+	inc = '
+	inline double square(double x){ return x*x ; }
+	'
 )
 
-res.any <- benchmark( '
+settings.any <- list( start = '
 	NumericVector x = e["x"] ;
 	NumericVector y = e["y"] ;
 	int res ;
 	SEXP res2 ;
 
-', '
+', hand.written = '
 	int n = x.size() ;
 	bool seen_na = false ;
 	bool result = false ;
@@ -125,18 +167,34 @@
     		}
     	}
 	res = result ? TRUE : ( seen_na ? NA_LOGICAL : FALSE ) ;
-', '
+', sugar = '
 	res2 = any( x*y < 0 ) ;
 ',
-	quote(any(x*y<0)),
-        runs = 5000,
+	expr = quote(any(x*y<0)),
+	runs = 5000,
 	data = list(
 		x = seq( -1, 1, length = 1e05),
 		y = rep( 1, 1e05)
 	)
 )
+raw.results <- list( 
+ 	benchmark( settings = settings.any   , runs = 5000 ), 
+ 	benchmark( settings = settings.ifelse, runs = 500 ), 
+ 	benchmark( settings = settings.sapply, runs = 500 )
+)
+cat("\n")
 
-results <- rbind(as.data.frame( t( res.ifelse ) ),
-                 as.data.frame( t( res.any    ) ))
+results <- do.call( rbind, lapply( raw.results, "[[", "results" ) )
+results <- data.frame( 
+	runs = sapply( raw.results, "[[", "runs" ),
+	expr = sapply( raw.results, "[[", "expr" ),
+	as.data.frame( results, stringsAsFactors = FALSE )
+	)
+
+results[[ "hand/sugar" ]] <- results[["hand.written" ]] / results[["sugar"]] 
+results[[ "R/sugar" ]]    <- results[["R" ]]            / results[["sugar"]] 
+results <- results[ order( results[["expr"]], results[["runs"]] ), ]
+
+options( width = 300 )
 print( results )