Rcpp Version 0.12.14
sugarBenchmarks.R
Go to the documentation of this file.
1 #!/usr/bin/env r
2 
3 suppressMessages(library(inline))
4 suppressMessages(library(Rcpp))
5 
6 benchmark <- function(start = settings$start,
7  hand.written = settings$hand.written,
8  sugar = settings$sugar,
9  expr = settings$expr,
10  runs = settings$runs,
11  data = settings$data,
12  end = settings$end,
13  inc = settings$inc,
14 
15  settings = list(
16  start = "", hand.written = "",
17  sugar = "", expr = NULL,
18  runs = 500,
19  data = NULL ,
20  end = "",
21  inc = ""
22  )
23  ) {
24 
25 expr <- force(expr)
26 inc <- force( inc )
27 
28 src <- sprintf( '
29  unsigned int runs = as<int>(runss);
30  Environment e(env) ;
31 
32  %s
33 
34  Timer timer;
35 
36  // approach one
37  timer.Start();
38  for (unsigned int i=0; i<runs; i++) {
39  %s
40  }
41  timer.Stop();
42  double t1 = timer.ElapsedTime();
43 
44  // approach two
45  timer.Reset(); timer.Start();
46  for (unsigned int i=0; i<runs; i++) {
47  %s
48  }
49  timer.Stop();
50  double t2 = timer.ElapsedTime();
51 
52  Language call(expr) ;
53 
54  timer.Reset(); timer.Start();
55  for (unsigned int i=0; i<runs; i++) {
56  NumericVector res2 = Rcpp_eval( call, e ) ;
57  }
58  timer.Stop();
59  double t3 = timer.ElapsedTime();
60 
61  %s
62 
63  return NumericVector::create(
64  _["hand written"] = t1,
65  _["sugar"] = t2,
66  _["R"] = t3
67  ) ;
68 ',
69  paste( start, collapse = "\n" ) ,
70  paste( hand.written, collapse = "\n" ),
71  paste( sugar, collapse = "\n" ),
72  paste( end, collapse = "\n" )
73  )
74 
75  e <- environment()
76  for( i in names(data) ){
77  assign( i, data[[i]], envir = e )
78  }
79 
80  settings <- getPlugin("Rcpp")
81  settings$env$PKG_CXXFLAGS <- paste("-I", getwd(), sep="")
82 
83  fun <- cxxfunction(signature(runss="integer", expr = "language", env = "environment" ),
84  src,
85  includes= sprintf( '#include "Timer.h"\n%s', paste( inc, collapse = "\n" ) ),
86  plugin="Rcpp",
87  settings=settings)
88  results <- fun(runs, expr, environment() )
89  cat( "-" )
90  list( results = results, runs = runs, expr = deparse(expr) )
91 }
92 
93 settings.ifelse <- list( start = '
94  NumericVector x = e["x"] ;
95  NumericVector y = e["y"] ;
96 ', hand.written = '
97  int n = x.size() ;
98  NumericVector res1( n ) ;
99  double x_ = 0.0 ;
100  double y_ = 0.0 ;
101  for( int i=0; i<n; i++){
102  x_ = x[i] ;
103  y_ = y[i] ;
104  if( R_IsNA(x_) || R_IsNA(y_) ){
105  res1[i] = NA_REAL;
106  } else if( x_ < y_ ){
107  res1[i] = x_ * x_ ;
108  } else {
109  res1[i] = -( y_ * y_) ;
110  }
111  }
112 
113 ', sugar = '
114  NumericVector res2 = ifelse( x < y, x*x, -(y*y) ) ;
115 ', expr = quote(ifelse(x<y, x*x, -(y*y) )),
116  data = list( x = runif(1e5), y = runif(1e5) )
117 )
118 
119 settings.ifelse.nona <- list( start = '
120  NumericVector x = e["x"] ;
121  NumericVector y = e["y"] ;
122 ', hand.written = '
123  int n = x.size() ;
124  NumericVector res1( n ) ;
125  double x_ = 0.0 ;
126  double y_ = 0.0 ;
127  for( int i=0; i<n; i++){
128  x_ = x[i] ;
129  y_ = y[i] ;
130  if( x_ < y_ ){
131  res1[i] = x_ * x_ ;
132  } else {
133  res1[i] = -( y_ * y_) ;
134  }
135  }
136 
137 ', sugar = '
138  NumericVector res2 = ifelse( x < y, noNA(x)*noNA(x), -(noNA(y)*noNA(y)) ) ;
139 ', expr = quote(ifelse(x<y, x*x, -(y*y) )),
140  data = list( x = runif(1e5), y = runif(1e5) )
141 )
142 
143 settings.sapply <- list( start = '
144  NumericVector x = e["x"] ;
145  int n = x.size() ;
146 
147 ', hand.written = '
148  NumericVector res1( n ) ;
149  std::transform( x.begin(), x.end(), res1.begin(), square ) ;
150 
151 ', sugar = '
152  NumericVector res2 = sapply( x, square ) ;
153 ',
154  expr = quote(sapply(x,square)),
155  runs = 500,
156  data = list(
157  x = rnorm(1e5) ,
158  square = function(x) x*x
159  ),
160  inc = '
161  inline double square(double x){ return x*x ; }
162  '
163 )
164 
165 settings.any <- list( start = '
166  NumericVector x = e["x"] ;
167  NumericVector y = e["y"] ;
168  int res ;
169  SEXP res2 ;
170 
171 ', hand.written = '
172  int n = x.size() ;
173  bool seen_na = false ;
174  bool result = false ;
175  double x_ = 0.0 ;
176  double y_ = 0.0 ;
177  for( int i=0; i<n; i++){
178  x_ = x[i] ;
179  if( R_IsNA( x_ ) ){
180  seen_na = true ;
181  } else {
182  y_ = y[i] ;
183  if( R_IsNA( y_ ) ){
184  seen_na = true ;
185  } else {
186  /* both non NA */
187  if( x_*y_ < 0.0 ){
188  result = true ;
189  break ;
190  }
191  }
192  }
193  }
194  res = result ? TRUE : ( seen_na ? NA_LOGICAL : FALSE ) ;
195 ', sugar = '
196  res2 = any( x*y < 0 ) ;
197 ',
198  expr = quote(any(x*y<0)),
199  runs = 5000,
200  data = list(
201  x = seq( -1, 1, length = 1e05),
202  y = rep( 1, 1e05)
203  )
204 )
205 raw.results <- list(
206  benchmark( settings = settings.any , runs = 5000 ),
207  benchmark( settings = settings.ifelse, runs = 500 ),
208  benchmark( settings = settings.ifelse.nona, runs = 500 ),
209  benchmark( settings = settings.sapply, runs = 500 )
210 )
211 cat("\n")
212 
213 results <- do.call( rbind, lapply( raw.results, "[[", "results" ) )
214 results <- data.frame(
215  runs = sapply( raw.results, "[[", "runs" ),
216  expr = sapply( raw.results, "[[", "expr" ),
217  as.data.frame( results, stringsAsFactors = FALSE )
218  )
219 
220 results[[ "hand/sugar" ]] <- results[["hand.written" ]] / results[["sugar"]]
221 results[[ "R/sugar" ]] <- results[["R" ]] / results[["sugar"]]
222 # results <- results[ order( results[["expr"]], results[["runs"]] ), ]
223 
224 options( width = 300 )
225 print( results )
226