Rcpp Version 1.0.9
exampleRCode.r
Go to the documentation of this file.
1 #!/usr/bin/env r
2 
3 suppressMessages(require(Rcpp))
4 set.seed(42)
5 n <- 200
6 a <- rnorm(n)
7 b <- rnorm(n)
8 
9 ## load shared libraries with wrapper code
10 dyn.load("convolve2_c.so")
11 dyn.load("convolve3_cpp.so")
12 dyn.load("convolve4_cpp.so")
13 dyn.load("convolve5_cpp.so")
14 dyn.load("convolve7_c.so")
15 
16 dyn.load("convolve8_cpp.so")
17 dyn.load("convolve9_cpp.so")
18 dyn.load("convolve10_cpp.so")
19 dyn.load("convolve11_cpp.so")
20 dyn.load("convolve12_cpp.so" )
21 dyn.load("convolve14_cpp.so" )
22 
23 ## now run each one once for comparison of results,
24 ## and define test functions
25 
26 R_API_optimised <- function(n,a,b) .Call("convolve2__loop", n, a, b)
27 Rcpp_New_std <- function(n,a,b) .Call("convolve3cpp__loop", n, a, b)
28 #Rcpp_New_std_inside <- function(n,a,b) .Call("convolve3cpp__loop", n, a, b, PACKAGE = "Rcpp" )
29 Rcpp_New_ptr <- function(n,a,b) .Call("convolve4cpp__loop", n, a, b)
30 Rcpp_New_sugar <- function(n,a,b) .Call("convolve5cpp__loop", n, a, b)
31 Rcpp_New_sugar_noNA <- function(n,a,b) .Call("convolve11cpp__loop", n, a, b)
32 R_API_naive <- function(n,a,b) .Call("convolve7__loop", n, a, b)
33 Rcpp_New_std_2 <- function(n,a,b) .Call("convolve8cpp__loop", n, a, b)
34 #Rcpp_New_std_3 <- function(n,a,b) .Call("convolve9cpp__loop", n, a, b)
35 #Rcpp_New_std_4 <- function(n,a,b) .Call("convolve10cpp__loop", n, a, b)
36 Rcpp_New_std_it <- function(n,a,b) .Call("convolve12cpp__loop", n, a, b )
37 Rcpp_New_std_Fast <- function(n,a,b) .Call("convolve14cpp__loop", n, a, b )
38 
39 
40 v1 <- R_API_optimised(1L, a, b )
41 v3 <- Rcpp_New_std(1L, a, b)
42 v4 <- Rcpp_New_ptr(1L, a, b)
43 v5 <- Rcpp_New_sugar(1L, a, b )
44 v7 <- R_API_naive(1L, a, b)
45 v11 <- Rcpp_New_sugar_noNA(1L, a, b)
46 
47 stopifnot(all.equal(v1, v3))
48 stopifnot(all.equal(v1, v4))
49 stopifnot(all.equal(v1, v5))
50 stopifnot(all.equal(v1, v7))
51 stopifnot(all.equal(v1, v11))
52 
53 ## load benchmarkin helper function
54 suppressMessages(library(rbenchmark))
55 REPS <- 5000L
56 bm <- benchmark(R_API_optimised(REPS,a,b),
57  R_API_naive(REPS,a,b),
58  Rcpp_New_std(REPS,a,b),
59 # Rcpp_New_std_inside(REPS,a,b),
60  Rcpp_New_ptr(REPS,a,b),
61  Rcpp_New_sugar(REPS,a,b),
62  Rcpp_New_sugar_noNA(REPS,a,b),
63  Rcpp_New_std_2(REPS,a,b),
64 # Rcpp_New_std_3(REPS,a,b),
65 # Rcpp_New_std_4(REPS,a,b),
66  Rcpp_New_std_it(REPS,a,b),
67  Rcpp_New_std_Fast(REPS,a,b),
68  columns=c("test", "elapsed", "relative", "user.self", "sys.self"),
69  order="relative",
70  replications=1)
71 print(bm)
72 
73 cat("All results are equal\n") # as we didn't get stopped
74 q("no")
75 
76 
77 sizes <- 1:10*100
78 REPS <- 5000L
79 timings <- lapply( sizes, function(size){
80  cat( "size = ", size, "..." )
81  a <- rnorm(size); b <- rnorm(size)
82  bm <- benchmark(R_API_optimised(REPS,a,b),
83  R_API_naive(REPS,a,b),
84  Rcpp_New_std(REPS,a,b),
85  Rcpp_New_ptr(REPS,a,b),
86  Rcpp_New_sugar(REPS,a,b),
87  Rcpp_New_sugar_noNA(REPS,a,b),
88  columns=c("test", "elapsed", "relative", "user.self", "sys.self"),
89  order="relative",
90  replications=1)
91 
92  cat( " done\n" )
93  bm
94 } )
95 for( i in seq_along(sizes)){
96  timings[[i]]$size <- sizes[i]
97 }
98 timings <- do.call( rbind, timings )
99 
100 require( lattice )
101 png( "elapsed.png", width = 800, height = 600 )
102 xyplot( elapsed ~ size, groups = test, data = timings, auto.key = TRUE, type = "l", lwd = 2 )
103 dev.off()
104 png( "relative.png", width = 800, height = 600 )
105 xyplot( relative ~ size, groups = test, data = timings, auto.key = TRUE, type = "l", lwd = 2 )
106 dev.off()
107