[Rcpp-commits] r1739 - pkg/Rcpp/inst/examples/SugarPerformance
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jun 25 17:23:25 CEST 2010
Author: edd
Date: 2010-06-25 17:23:25 +0200 (Fri, 25 Jun 2010)
New Revision: 1739
Added:
pkg/Rcpp/inst/examples/SugarPerformance/sugarBenchmarks.R
Removed:
pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R
Log:
rename to sugarBenchmarks.R
Copied: pkg/Rcpp/inst/examples/SugarPerformance/sugarBenchmarks.R (from rev 1738, pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R)
===================================================================
--- pkg/Rcpp/inst/examples/SugarPerformance/sugarBenchmarks.R (rev 0)
+++ pkg/Rcpp/inst/examples/SugarPerformance/sugarBenchmarks.R 2010-06-25 15:23:25 UTC (rev 1739)
@@ -0,0 +1,200 @@
+
+suppressMessages(library(inline))
+suppressMessages(library(Rcpp))
+
+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) ;
+
+ %s
+
+ Timer timer;
+
+ // approach one
+ timer.Start();
+ for (unsigned int i=0; i<runs; i++) {
+ %s
+ }
+ timer.Stop();
+ double t1 = timer.ElapsedTime();
+
+ // approach two
+ timer.Reset(); timer.Start();
+ for (unsigned int i=0; i<runs; i++) {
+ %s
+ }
+ timer.Stop();
+ double t2 = timer.ElapsedTime();
+
+ Language call(expr) ;
+
+ timer.Reset(); timer.Start();
+ for (unsigned int i=0; i<runs; i++) {
+ NumericVector res2 = Rf_eval( call, e ) ;
+ }
+ timer.Stop();
+ double t3 = timer.ElapsedTime();
+
+ %s
+
+ return NumericVector::create(
+ _["hand written"] = t1,
+ _["sugar"] = t2,
+ _["R"] = t3
+ ) ;
+',
+ paste( start, collapse = "\n" ) ,
+ paste( hand.written, collapse = "\n" ),
+ paste( sugar, collapse = "\n" ),
+ paste( end, collapse = "\n" )
+ )
+
+ e <- environment()
+ for( i in names(data) ){
+ assign( i, data[[i]], envir = e )
+ }
+
+ settings <- getPlugin("Rcpp")
+ settings$env$PKG_CXXFLAGS <- paste("-I", getwd(), " -O0", sep="")
+
+ fun <- cxxfunction(signature(runss="integer", expr = "language", env = "environment" ),
+ src,
+ includes= sprintf( '#include "Timer.h"\n%s', paste( inc, collapse = "\n" ) ),
+ plugin="Rcpp",
+ settings=settings)
+ results <- fun(runs, expr, environment() )
+ cat( "-" )
+ list( results = results, runs = runs, expr = deparse(expr) )
+}
+
+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 ;
+ double y_ = 0.0 ;
+ for( int i=0; i<n; i++){
+ x_ = x[i] ;
+ y_ = y[i] ;
+ if( R_IsNA(x_) || R_IsNA(y_) ){
+ res1[i] = NA_REAL;
+ } else if( x_ < y_ ){
+ res1[i] = x_ * x_ ;
+ } else {
+ res1[i] = -( y_ * y_) ;
+ }
+ }
+
+', 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 ) ;
+',
+ 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 ; }
+ '
+)
+
+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 ;
+ double x_ = 0.0 ;
+ double y_ = 0.0 ;
+ for( int i=0; i<n; i++){
+ x_ = x[i] ;
+ if( R_IsNA( x_ ) ){
+ seen_na = true ;
+ } else {
+ y_ = y[i] ;
+ if( R_IsNA( y_ ) ){
+ seen_na = true ;
+ } else {
+ /* both non NA */
+ if( x_*y_ < 0.0 ){
+ result = true ;
+ break ;
+ }
+ }
+ }
+ }
+ res = result ? TRUE : ( seen_na ? NA_LOGICAL : FALSE ) ;
+', sugar = '
+ res2 = any( x*y < 0 ) ;
+',
+ 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 <- 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 )
+
Deleted: pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R
===================================================================
--- pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R 2010-06-25 15:05:42 UTC (rev 1738)
+++ pkg/Rcpp/inst/examples/SugarPerformance/vectorOps.R 2010-06-25 15:23:25 UTC (rev 1739)
@@ -1,200 +0,0 @@
-
-suppressMessages(library(inline))
-suppressMessages(library(Rcpp))
-
-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) ;
-
- %s
-
- Timer timer;
-
- // approach one
- timer.Start();
- for (unsigned int i=0; i<runs; i++) {
- %s
- }
- timer.Stop();
- double t1 = timer.ElapsedTime();
-
- // approach two
- timer.Reset(); timer.Start();
- for (unsigned int i=0; i<runs; i++) {
- %s
- }
- timer.Stop();
- double t2 = timer.ElapsedTime();
-
- Language call(expr) ;
-
- timer.Reset(); timer.Start();
- for (unsigned int i=0; i<runs; i++) {
- NumericVector res2 = Rf_eval( call, e ) ;
- }
- timer.Stop();
- double t3 = timer.ElapsedTime();
-
- %s
-
- return NumericVector::create(
- _["hand written"] = t1,
- _["sugar"] = t2,
- _["R"] = t3
- ) ;
-',
- paste( start, collapse = "\n" ) ,
- paste( hand.written, collapse = "\n" ),
- paste( sugar, collapse = "\n" ),
- paste( end, collapse = "\n" )
- )
-
- e <- environment()
- for( i in names(data) ){
- assign( i, data[[i]], envir = e )
- }
-
- settings <- getPlugin("Rcpp")
- settings$env$PKG_CXXFLAGS <- paste("-I", getwd(), " -O0", sep="")
-
- fun <- cxxfunction(signature(runss="integer", expr = "language", env = "environment" ),
- src,
- includes= sprintf( '#include "Timer.h"\n%s', paste( inc, collapse = "\n" ) ),
- plugin="Rcpp",
- settings=settings)
- results <- fun(runs, expr, environment() )
- cat( "-" )
- list( results = results, runs = runs, expr = deparse(expr) )
-}
-
-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 ;
- double y_ = 0.0 ;
- for( int i=0; i<n; i++){
- x_ = x[i] ;
- y_ = y[i] ;
- if( R_IsNA(x_) || R_IsNA(y_) ){
- res1[i] = NA_REAL;
- } else if( x_ < y_ ){
- res1[i] = x_ * x_ ;
- } else {
- res1[i] = -( y_ * y_) ;
- }
- }
-
-', 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 ) ;
-',
- 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 ; }
- '
-)
-
-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 ;
- double x_ = 0.0 ;
- double y_ = 0.0 ;
- for( int i=0; i<n; i++){
- x_ = x[i] ;
- if( R_IsNA( x_ ) ){
- seen_na = true ;
- } else {
- y_ = y[i] ;
- if( R_IsNA( y_ ) ){
- seen_na = true ;
- } else {
- /* both non NA */
- if( x_*y_ < 0.0 ){
- result = true ;
- break ;
- }
- }
- }
- }
- res = result ? TRUE : ( seen_na ? NA_LOGICAL : FALSE ) ;
-', sugar = '
- res2 = any( x*y < 0 ) ;
-',
- 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 <- 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 )
-
More information about the Rcpp-commits
mailing list