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