Code For Ra Timing Tests
To Ra homepage
# time-jit.R
library(jit)
library(compiler)
QUICK.FLAG <- FALSE # FALSE for full test, TRUE for quick test
# QUICK.FLAG <- TRUE
NREPEATS <- 5 # for calculating time stddev
if (QUICK.FLAG == 1)
NREPEATS <- 1
JIT.FLAG <- 0
TRACE.FLAG <- 0
# Loop counts are chosen so the jitted times are greater
# than about a second (on a 3G Pentium).
# This is necessary for plausible timing results.
# We adjust N below so each jitted test takes roughly the same time.
N <- if (QUICK.FLAG) 2e6 else 2e7
gctorture(0)
print(R.version.string)
test <- function(f, f.compile, f.jit, N)
{
# na.rm=TRUE is useful when building the framework with very short times
percent.relative.sd <- function(x) sprintf("[%.2f]", 100 * sd(x, na.rm=TRUE) / mean(x))
cat(sprintf("%-24.24s%9.0f ", paste(substitute(f)), N))
time <- time.compile <- time.jit1 <- time.jit2 <- time.jit3 <- double(NREPEATS)
N <- as.integer(N) # use an integer index in for loops
for (i in 1:NREPEATS) {
switch(NREPEATS %% 3 + 1, # change order of evaluation, probably unnecessary
{
gc()
time[i] <- system.time(no.jit.result <- f(N))[3]
gc()
time.compile[i] <- system.time(compile.result <- f.compile(N))[3]
if (is.ra) {
JIT.FLAG <<- 1
gc()
time.jit1[i] <- system.time(jit.result1 <- f.jit(N))[3]
JIT.FLAG <<- 2
gc()
time.jit2[i] <- system.time(jit.result2 <- f.jit(N))[3]
JIT.FLAG <<- 3
gc()
time.jit3[i] <- system.time(jit.result3 <- f.jit(N))[3]
}
},
{
gc()
time.compile[i] <- system.time(compile.result <- f.compile(N))[3]
if (is.ra) {
JIT.FLAG <<- 2
gc()
time.jit2[i] <- system.time(jit.result2 <- f.jit(N))[3]
JIT.FLAG <<- 3
gc()
time.jit3[i] <- system.time(jit.result3 <- f.jit(N))[3]
JIT.FLAG <<- 1
gc()
time.jit1[i] <- system.time(jit.result1 <- f.jit(N))[3]
}
gc()
time[i] <- system.time(no.jit.result <- f(N))[3]
},
{
if (is.ra) {
JIT.FLAG <<- 3
gc()
time.jit3[i] <- system.time(jit.result3 <- f.jit(N))[3]
JIT.FLAG <<- 1
gc()
time.jit1[i] <- system.time(jit.result1 <- f.jit(N))[3]
JIT.FLAG <<- 2
gc()
time.jit2[i] <- system.time(jit.result2 <- f.jit(N))[3]
}
gc()
time[i] <- system.time(no.jit.result <- f(N))[3]
gc()
time.compile[i] <- system.time(compile.result <- f.compile(N))[3]
})
}
cat(sprintf(" %6.2f %6.6s ",
mean(time),
percent.relative.sd(time)))
cat(sprintf("%7.1f %6.6s ",
mean(time / time.compile),
percent.relative.sd(time / time.compile)))
if (is.ra) {
cat(sprintf("%7.1f %6.6s %7.1f %6.6s %7.1f %6.6s",
mean(time / time.jit1),
percent.relative.sd(time / time.jit1),
mean(time / time.jit2),
percent.relative.sd(time / time.jit2),
mean(time / time.jit3),
percent.relative.sd(time / time.jit3)))
}
cat("\n")
stopifnot(identical(no.jit.result, compile.result))
if (is.ra) {
stopifnot(identical(no.jit.result, jit.result1))
stopifnot(identical(no.jit.result, jit.result2))
stopifnot(identical(no.jit.result, jit.result3))
}
}
convolve <- function(N) # from the extending R manual
{
a <- double(N)
b <- double(N)
na <- length(a)
nb <- length(b)
ab <- double(na + nb - 1)
for(i in 1:na)
for(j in 1:nb)
ab[i + j - 1] <- ab[i + j - 1] + a[i] * b[j]
ab
}
convolve.comp <- cmpfun(convolve)
convolve.jit <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
a <- double(N)
b <- double(N)
na <- length(a)
nb <- length(b)
ab <- double(na + nb - 1)
for(i in 1:na)
for(j in 1:nb)
ab[i + j - 1] <- ab[i + j - 1] + a[i] * b[j]
ab
}
# from Ross' Otago talk "The R Project: A Brief History and Thoughts About the Future"
otago <- function(x, y)
{
nx = numeric(length(y))
for(j in 1:length(y)) {
dmin = Inf
imin = 0L
for(i in 1:length(x)) {
d = abs(x[i] - y[j])
if (d < dmin) {
dmin = d
imin = i
}
}
nx[j] = x[imin]
}
nx
}
otago.comp <- cmpfun(otago)
otago.jit <- function(x, y)
{
jit(JIT.FLAG, TRACE.FLAG)
nx = numeric(length(y))
for(j in 1:length(y)) {
dmin = Inf
imin = 0L
for(i in 1:length(x)) {
d = abs(x[i] - y[j])
if (d < dmin) {
dmin = d
imin = i
}
}
nx[j] = x[imin]
}
nx
}
otago.wrapper <- function(N)
{
otago(x, y)
}
otago.wrapper.comp <- function(N)
{
otago.comp(x, y)
}
otago.wrapper.jit <- function(N)
{
otago.jit(x, y)
}
# from base/TAOCP.R, a good test of integer arithmetic
.TAOCP1997init <- function(seed)
{
seed <- as.integer(seed) # added for jit to prevent type change error
KK <- 100L; LL <- 37L; MM <- as.integer(2^30)
KKK <- KK + KK - 1L; KKL <- KK - LL
ss <- seed - (seed %% 2L) + 2L
X <- integer(KKK)
for(j in 1L:KK) {
X[j] <- ss
ss <- ss+ss
if(ss >= MM) ss <- ss - MM + 2L
}
X[2L] <- X[2L] + 1L
ss <- seed
T <- 69L
while(T > 0) {
for(j in KK:2L) X[j + j - 1L] <- X[j]
for(j in seq(KKK, KKL + 1L, -2L))
X[KKK - j + 2L] <- X[j] - (X[j] %% 2L)
for(j in KKK:(KK+1L))
if(X[j] %% 2L == 1L) {
X[j - KKL] <- (X[j - KKL] - X[j]) %% MM
X[j - KK] <- (X[j - KK] - X[j]) %% MM
}
if(ss %% 2L == 1L) {
for(j in KK:1L) X[j + 1L] <- X[j]
X[1L] <- X[KK + 1L]
if(X[KK + 1L] %% 2L == 1L)
X[LL + 1L] <- (X[LL + 1L] - X[KK + 1L]) %% MM
}
if(ss) ss <- ss %/% 2L else T <- T - 1L
}
rs <- c(X[(LL+1L):KK], X[1L:LL])
invisible(rs)
}
.TAOCP1997init.comp <- cmpfun(.TAOCP1997init)
.TAOCP1997init.jit <- function(seed)
{
seed <- as.integer(seed) # added for jit to prevent type change error
jit(JIT.FLAG, TRACE.FLAG)
KK <- 100L; LL <- 37L; MM <- as.integer(2^30)
KKK <- KK + KK - 1L; KKL <- KK - LL
ss <- seed - (seed %% 2L) + 2L
X <- integer(KKK)
for(j in 1L:KK) {
X[j] <- ss
ss <- ss+ss
if(ss >= MM) ss <- ss - MM + 2L
}
X[2L] <- X[2L] + 1L
ss <- seed
T <- 69L
while(T > 0) {
for(j in KK:2L) X[j + j - 1L] <- X[j]
for(j in seq(KKK, KKL + 1L, -2L))
X[KKK - j + 2L] <- X[j] - (X[j] %% 2L)
for(j in KKK:(KK+1L))
if(X[j] %% 2L == 1L) {
X[j - KKL] <- (X[j - KKL] - X[j]) %% MM
X[j - KK] <- (X[j - KK] - X[j]) %% MM
}
if(ss %% 2L == 1L) {
for(j in KK:1L) X[j + 1L] <- X[j]
X[1L] <- X[KK + 1L]
if(X[KK + 1L] %% 2L == 1L)
X[LL + 1L] <- (X[LL + 1L] - X[KK + 1L]) %% MM
}
if(ss) ss <- ss %/% 2L else T <- T - 1L
}
rs <- c(X[(LL+1L):KK], X[1L:LL])
invisible(rs)
}
`base/TAOCP.R` <- function(N)
{
x <- 0
for (i in 1:N)
x <- c(x, .TAOCP1997init(i))
x
}
`base/TAOCP.R.comp` <- function(N)
{
x <- 0
for (i in 1:N)
x <- c(x, .TAOCP1997init.comp(i))
x
}
`base/TAOCP.R.jit` <- function(N)
{
x <- 0
for (i in 1:N)
x <- c(x, .TAOCP1997init.jit(i))
x
}
# from ROCR package, calculate area under ROC curve
.performance.auc <-
function(predictions, labels, cutoffs, fp, tp, fn, tn,
n.pos, n.neg, n.pos.pred, n.neg.pred, fpr.stop) {
x <- fp / n.neg
y <- tp / n.pos
finite.bool <- is.finite(x) & is.finite(y)
x <- x[ finite.bool ]
y <- y[ finite.bool ]
if (length(x) < 2) {
stop(paste("Not enough distinct predictions to compute area",
"under the ROC curve."))
}
if (fpr.stop < 1) {
ind <- max(which( x <= fpr.stop ))
tpr.stop <- approxfun( x[ind:(ind+1)], y[ind:(ind+1)] )(fpr.stop)
x <- c(x[1:ind], fpr.stop)
y <- c(y[1:ind], tpr.stop)
}
ans <- list()
auc <- 0
for (i in 2:length(x)) {
auc <- auc + 0.5 * (x[i] - x[i-1]) * (y[i] + y[i-1])
}
ans <- list( c(), auc)
names(ans) <- c("x.values","y.values")
return(ans)
}
.performance.auc.comp <- cmpfun(.performance.auc)
.performance.auc.jit <-
function(predictions, labels, cutoffs, fp, tp, fn, tn,
n.pos, n.neg, n.pos.pred, n.neg.pred, fpr.stop) {
jit(JIT.FLAG, TRACE.FLAG)
x <- fp / n.neg
y <- tp / n.pos
finite.bool <- is.finite(x) & is.finite(y)
x <- x[ finite.bool ]
y <- y[ finite.bool ]
if (length(x) < 2) {
stop(paste("Not enough distinct predictions to compute area",
"under the ROC curve."))
}
if (fpr.stop < 1) {
ind <- max(which( x <= fpr.stop ))
tpr.stop <- approxfun( x[ind:(ind+1)], y[ind:(ind+1)] )(fpr.stop)
x <- c(x[1:ind], fpr.stop)
y <- c(y[1:ind], tpr.stop)
}
ans <- list()
auc <- 0
for (i in 2:length(x)) {
auc <- auc + 0.5 * (x[i] - x[i-1]) * (y[i] + y[i-1])
}
ans <- list( c(), auc)
names(ans) <- c("x.values","y.values")
return(ans)
}
`ROCR/auc` <- function(N)
{
.performance.auc(predictions=NULL, labels=NULL,
cutoffs=NULL, fp=fp, tp=tp,
fn=NULL, tn=NULL, n.pos=length(tp), n.neg=length(fp),
n.pos.pred=NULL, n.neg.pred=NULL, fpr.stop=1)
}
`ROCR/auc.comp` <- function(N)
{
.performance.auc.comp(predictions=NULL, labels=NULL,
cutoffs=NULL, fp=fp, tp=tp,
fn=NULL, tn=NULL, n.pos=length(tp), n.neg=length(fp),
n.pos.pred=NULL, n.neg.pred=NULL, fpr.stop=1)
}
`ROCR/auc.jit` <- function(N)
{
.performance.auc.jit(predictions=NULL, labels=NULL,
cutoffs=NULL, fp=fp, tp=tp,
fn=NULL, tn=NULL, n.pos=length(tp), n.neg=length(fp),
n.pos.pred=NULL, n.neg.pred=NULL, fpr.stop=1)
}
# Distribution of determinant of 2x2 matrix
# From V&R S Programming p154
dd.for.c <- function()
{
val <- NULL
for (a in 0:9)
for (b in 0:9)
for (d in 0:9)
for (e in 0:9)
val <- c(val, a*b - d*e)
table(val)
}
dd.for.c.comp <- cmpfun(dd.for.c)
dd.for.c.jit <- function()
{
jit(JIT.FLAG, TRACE.FLAG)
val <- NULL
nojit(val) # allow "c" below to change len of val
for (a in 0:9)
for (b in 0:9)
for (d in 0:9)
for (e in 0:9)
val <- c(val, a*b - d*e)
table(val)
}
dd.for.c.wrapper <- function(N)
{
for (i in 1:N)
dd.for.c()
}
dd.for.c.wrapper.comp <- function(N)
{
for (i in 1:N)
dd.for.c.comp()
}
dd.for.c.wrapper.jit <- function(N)
{
for (i in 1:N)
dd.for.c.jit()
}
dd.for.prealloc <- function()
{
val <- double(10000) # was val <- NULL
nval <- 0
for (a in 0:9)
for (b in 0:9)
for (d in 0:9)
for (e in 0:9)
val[nval <- nval + 1] <- a*b - d*e
# was val <- c(val, a*b - d*e)
table(val)
}
dd.for.prealloc.comp <- cmpfun(dd.for.prealloc)
dd.for.prealloc.jit <- function()
{
jit(JIT.FLAG, TRACE.FLAG)
val <- double(10000) # was val <- NULL
nval <- 0
for (a in 0:9)
for (b in 0:9)
for (d in 0:9)
for (e in 0:9)
val[nval <- nval + 1] <- a*b - d*e
# was val <- c(val, a*b - d*e)
table(val)
}
dd.for.prealloc.wrapper <- function(N)
{
for (i in 1:N)
dd.for.prealloc()
}
dd.for.prealloc.wrapper.comp <- function(N)
{
for (i in 1:N)
dd.for.prealloc.comp()
}
dd.for.prealloc.wrapper.jit <- function(N)
{
for (i in 1:N)
dd.for.prealloc.jit()
}
dd.for.tabulate <- function()
{
val <- double(10000) # was val <- NULL
nval <- 0
for (a in 0:9)
for (b in 0:9)
for (d in 0:9)
for (e in 0:9)
val[nval <- nval + 1] <- a*b - d*e
# was val <- c(val, a*b - d*e)
tabulate(val)
}
dd.for.tabulate.comp <- cmpfun(dd.for.tabulate)
dd.for.tabulate.jit <- function()
{
jit(JIT.FLAG, TRACE.FLAG)
val <- double(10000) # was val <- NULL
nval <- 0
for (a in 0:9)
for (b in 0:9)
for (d in 0:9)
for (e in 0:9)
val[nval <- nval + 1] <- a*b - d*e
# was val <- c(val, a*b - d*e)
tabulate(val)
}
dd.for.tabulate.wrapper <- function(N)
{
for (i in 1:N)
dd.for.tabulate()
}
dd.for.tabulate.wrapper.jit <- function(N)
{
for (i in 1:N)
dd.for.tabulate.jit()
}
dd.for.tabulate.wrapper.comp <- function(N)
{
for (i in 1:N)
dd.for.tabulate.comp()
}
dd.fast <- function()
{
val <- outer(0:9, 0:9, "*")
val <- outer(val, val, "-")
table(val + 82)
}
dd.fast.comp <- cmpfun(dd.fast)
dd.fast.jit <- function()
{
jit(JIT.FLAG, TRACE.FLAG)
val <- outer(0:9, 0:9, "*")
val <- outer(val, val, "-")
table(val + 82)
}
dd.fast.wrapper <- function(N)
{
for (i in 1:N)
dd.fast()
}
dd.fast.wrapper.comp <- function(N)
{
for (i in 1:N)
dd.fast.comp()
}
dd.fast.wrapper.jit <- function(N)
{
for (i in 1:N)
dd.fast.jit()
}
dd.fast.tabulate <- function()
{
val <- outer(0:9, 0:9, "*")
val <- outer(val, val, "-")
tabulate(val)
}
dd.fast.tabulate.comp <- cmpfun(dd.fast.tabulate)
dd.fast.tabulate.jit <- function()
{
jit(JIT.FLAG, TRACE.FLAG)
val <- outer(0:9, 0:9, "*")
val <- outer(val, val, "-")
tabulate(val)
}
dd.fast.tabulate.wrapper <- function(N)
{
for (i in 1:N)
dd.fast.tabulate()
}
dd.fast.tabulate.wrapper.comp <- function(N)
{
for (i in 1:N)
dd.fast.tabulate.comp()
}
dd.fast.tabulate.wrapper.jit <- function(N)
{
for (i in 1:N)
dd.fast.tabulate.jit()
}
looped.dnorm <- function(N)
{
mu <- 0
sigma <- 1
x <- 0
for (i in 1:N) # from one of Luke's compiler documents
x <- x + (1/sqrt(2 * pi)) * exp(-0.5 * ((x - mu)/sigma)^2) / sigma
x
}
looped.dnorm.comp <- cmpfun(looped.dnorm)
looped.dnorm.jit <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
mu <- 0
sigma <- 1
x <- 0
for (i in 1:N) # from one of Luke's compiler documents
x <- x + (1/sqrt(2 * pi)) * exp(-0.5 * ((x - mu)/sigma)^2) / sigma
x
}
`while x <- x + 1` <- function(N)
{
x <- 0
while (x < N)
x <- x+1
x
}
`while x <- x + 1.comp` <- cmpfun(`while x <- x + 1`)
`while x <- x + 1.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
x <- 0
while (x < N)
x <- x+1
x
}
`while x <- x + 1i` <- function(N)
{
i <- 0i
Ni <- N + 0i
while (i != Ni)
i <- i + 1
i
}
`while x <- x + 1i.comp` <- cmpfun(`while x <- x + 1i`)
`while x <- x + 1i.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
i <- 0i
Ni <- N + 0i
while (i != Ni)
i <- i + 1
i
}
`repeat x <- x + 1` <- function(N)
{
x <- 0
repeat {
x <- x+1
if (x >= N)
break;
}
x
}
`repeat x <- x + 1.comp` <- cmpfun(`repeat x <- x + 1`)
`repeat x <- x + 1.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
x <- 0
repeat {
x <- x+1
if (x >= N)
break;
}
x
}
`repeat x <- x + 1i` <- function(N)
{
x <- 0i
repeat {
x <- x+1
if (Re(x) >= N)
break;
}
x
}
`repeat x <- x + 1i.comp` <- cmpfun(`repeat x <- x + 1i`)
`repeat x <- x + 1i.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
x <- 0i
repeat {
x <- x+1
if (Re(x) >= N)
break;
}
x
}
`for.if` <- function(N)
{
iA <- seq(2,N); x <- double(N)
for (i in iA) {
if (i %% 2)
x <- x + 1
else
x <- x + 100
}
x
}
`for.if.comp` <- cmpfun(`for.if`)
`for.if.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
iA <- seq(2,N); x <- double(N)
for (i in iA) {
if (i %% 2)
x <- x + 1
else
x <- x + 100
}
x
}
# Tests from Vadim Ogranovich post.
# See http://tolstoy.newcastle.edu.au/R/devel/05/04/0678.html
# Expressions are the same as Luke's email reply except
# that x and iA are local.
`vadim1 1` <- function(N)
{
iA <- seq(2,N); x <- double(N)
for (i in iA)
1
x
}
`vadim1 1.comp` <- cmpfun(`vadim1 1`)
`vadim1 1.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
iA <- seq(2,N); x <- double(N)
for (i in iA)
1
x
}
`vadim2 i` <- function(N)
{
iA <- seq(2,N);
for (i in iA)
i
i
}
`vadim2 i.comp` <- cmpfun(`vadim2 i`)
`vadim2 i.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
iA <- seq(2,N);
for (i in iA)
i
i
}
`vadim3 i-1` <- function(N)
{
iA <- seq(2,N);
for (i in iA)
i-1
i
}
`vadim3 i-1.comp` <- cmpfun(`vadim3 i-1`)
`vadim3 i-1.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
iA <- seq(2,N);
for (i in iA)
i-1
i
}
`add1 x <- x + 1` <- function(N)
{
x <- 0
for(i in 1:N)
x <- x+1
x
}
`add1 x <- x + 1.comp` <- cmpfun(`add1 x <- x + 1`)
`add1 x <- x + 1.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
x <- 0
for(i in 1:N)
x <- x+1
x
}
`vadim4 x[i-1]` <- function(N)
{
iA <- seq(2,N); x <- double(N); x[1] <- 1; x[2] <- 2
for (i in iA)
x[i-1]
x
}
`vadim4 x[i-1].comp` <- cmpfun(`vadim4 x[i-1]`)
`vadim4 x[i-1].jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
iA <- seq(2,N); x <- double(N); x[1] <- 1; x[2] <- 2
for (i in iA)
x[i-1]
x
}
`vadim5 x[i] <- 1.0` <- function(N)
{
iA <- seq(2,N); x <- double(N); x[1] <- 1; x[2] <- 2
for (i in iA)
x[i] <- 1.0
x
}
`vadim5 x[i] <- 1.0.comp` <- cmpfun(`vadim5 x[i] <- 1.0`)
`vadim5 x[i] <- 1.0.jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
iA <- seq(2,N); x <- double(N); x[1] <- 1; x[2] <- 2
for (i in iA)
x[i] <- 1.0
x
}
`vadim6 x[i] <- x[i-1]` <- function(N)
{
iA <- seq(2,N); x <- double(N); x[1] <- 1; x[2] <- 2
for (i in iA)
x[i] <- x[i-1]
x
}
`vadim6 x[i] <- x[i-1].comp` <- cmpfun(`vadim6 x[i] <- x[i-1]`)
`vadim6 x[i] <- x[i-1].jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
iA <- seq(2,N); x <- double(N); x[1] <- 1; x[2] <- 2
for (i in iA)
x[i] <- x[i-1]
x
}
`x[i,1]` <- function(N)
{
iA <- seq(2,N); x <- matrix(as.double(1:N), nrow=N, ncol=2)
for (i in iA)
x[i,1]
x
}
`x[i,1].comp` <- cmpfun(`x[i,1]`)
`x[i,1].jit` <- function(N)
{
jit(JIT.FLAG, TRACE.FLAG)
iA <- seq(2,N); x <- matrix(as.double(1:N), nrow=N, ncol=2)
for (i in iA)
x[i,1]
x
}
dirk1 <- function(N) { # http://dirk.eddelbuettel.com/blog
z.local <- z # Avoid Error: Cannot change jitted symbol "z" to local scope
for(i in 2:NROW(z.local)) {
z.local[i] <- ifelse(z.local[i-1]==1, 1, 0)
}
z.local
}
dirk1.comp <- cmpfun(dirk1)
dirk1.jit <- function(N) {
jit(JIT.FLAG, TRACE.FLAG)
z.local <- z
for(i in 2:NROW(z.local)) {
z.local[i] <- ifelse(z.local[i-1]==1, 1, 0)
}
z.local
}
dirk2 <- function(N) {
z.local <- z
for(i in 2:NROW(z.local)) {
z.local[i] <- if(z.local[i-1]==1) 1 else 0
}
z.local
}
dirk2.comp <- cmpfun(dirk2)
dirk2.jit <- function(N) {
jit(JIT.FLAG, TRACE.FLAG)
z.local <- z
for(i in 2:NROW(z.local)) {
z.local[i] <- if(z.local[i-1]==1) 1 else 0
}
z.local
}
luke.la1 <- function(X, FUN, ...) { # from compile help page
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for(i in seq(along = X))
rval[i] <- list(FUN(X[[i]], ...))
names(rval) <- names(X)
return(rval)
}
luke.la1.comp <- cmpfun(luke.la1)
luke.la1.jit <- function(X, FUN, ...) {
jit(JIT.FLAG, TRACE.FLAG)
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for(i in seq(along = X))
rval[i] <- list(FUN(X[[i]], ...))
names(rval) <- names(X)
return(rval)
}
luke.la1.wrapper <- function(N)
{
luke.la1(x, is.null)
}
luke.la1.wrapper.comp <- function(N)
{
luke.la1.comp(x, is.null)
}
luke.la1.wrapper.jit <- function(N)
{
luke.la1.jit(x, is.null)
}
luke.la2 <- function(X, FUN, ...) {
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for(i in seq(along = X)) {
v <- FUN(X[[i]], ...)
if (is.null(v)) rval[i] <- list(v)
else rval[[i]] <- v
}
names(rval) <- names(X)
return(rval)
}
luke.la2.comp <- cmpfun(luke.la2)
luke.la2.jit <- function(X, FUN, ...) {
jit(JIT.FLAG, TRACE.FLAG)
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for(i in seq(along = X)) {
v <- FUN(X[[i]], ...)
if (is.null(v)) rval[i] <- list(v)
else rval[[i]] <- v
}
names(rval) <- names(X)
return(rval)
}
luke.la2.wrapper <- function(N)
{
luke.la2(x, is.null)
}
luke.la2.wrapper.comp <- function(N)
{
luke.la2.comp(x, is.null)
}
luke.la2.wrapper.jit <- function(N)
{
luke.la2.jit(x, is.null)
}
cat("is.ra", is.ra, "NREPEATS", NREPEATS, "QUICK.FLAG", QUICK.FLAG, "JIT.FLAG", JIT.FLAG, "\n\n")
cat(" standard R compiled jit=1 jit=2 jit=3\n")
cat("test N time [rsd%] ratio [rsd%] ratio [rsd%] ratio [rsd%] ratio [rsd%]\n\n")
test(convolve, convolve.comp, convolve.jit, if (QUICK.FLAG) 500 else 1600)
set.seed(1)
x = seq(0, 1, by = 1/((if(QUICK.FLAG) 5e2 else 2e3) -1))
y = runif(length(x))
test(otago.wrapper, otago.wrapper.comp, otago.wrapper.jit, if (QUICK.FLAG) 500 else 2000)
test(`base/TAOCP.R`, `base/TAOCP.R.comp`, `base/TAOCP.R.jit`, if (QUICK.FLAG) 20 else 80)
test(looped.dnorm, looped.dnorm.comp, looped.dnorm.jit, if (QUICK.FLAG) 1e5 else 8e5)
set.seed(1) # for reproducibility
fp = c(0, cumsum(runif(N / 10) > .5)) # cumulative false positives for `ROCR/auc`
tp = c(0, cumsum(runif(N / 10) > .5)) # cumulative true positives
test(`ROCR/auc`, `ROCR/auc.comp`, `ROCR/auc.jit`, N / 10)
cat("\n")
test(dd.for.c.wrapper, dd.for.c.wrapper.comp, dd.for.c.wrapper.jit, if (QUICK.FLAG) 20 else N / 30000)
test(dd.for.prealloc.wrapper, dd.for.prealloc.wrapper.comp, dd.for.prealloc.wrapper.jit, if (QUICK.FLAG) 20 else N / 30000)
test(dd.for.tabulate.wrapper, dd.for.tabulate.wrapper.comp, dd.for.tabulate.wrapper.jit, if (QUICK.FLAG) 20 else N / 30000)
test(dd.fast.wrapper, dd.fast.wrapper.comp, dd.fast.wrapper.jit, if (QUICK.FLAG) 20 else N / 30000)
test(dd.fast.tabulate.wrapper, dd.fast.tabulate.wrapper.comp, dd.fast.tabulate.wrapper.jit, if (QUICK.FLAG) 20 else N / 30000)
cat("\n")
test(`while x <- x + 1`, `while x <- x + 1.comp`, `while x <- x + 1.jit`, N / 5)
test(`repeat x <- x + 1`, `repeat x <- x + 1.comp`, `repeat x <- x + 1.jit`, N / 5)
test(`for.if`, `for.if.comp`, `for.if.jit`, 20000)
test(`while x <- x + 1i`, `while x <- x + 1i.comp`, `while x <- x + 1i.jit`, N / 5)
test(`repeat x <- x + 1i`, `repeat x <- x + 1i.comp`, `repeat x <- x + 1i.jit`, N / 5)
cat("\n")
test(`vadim1 1`, `vadim1 1.comp`, `vadim1 1.jit`, N)
test(`vadim2 i`, `vadim2 i.comp`, `vadim2 i.jit`, N)
test(`vadim3 i-1`, `vadim3 i-1.comp`, `vadim3 i-1.jit`, N)
test(`add1 x <- x + 1`, `add1 x <- x + 1.comp`, `add1 x <- x + 1.jit`, N)
test(`vadim4 x[i-1]`, `vadim4 x[i-1].comp`, `vadim4 x[i-1].jit`, N)
test(`vadim5 x[i] <- 1.0`, `vadim5 x[i] <- 1.0.comp`, `vadim5 x[i] <- 1.0.jit`, N)
test(`vadim6 x[i] <- x[i-1]`, `vadim6 x[i] <- x[i-1].comp`, `vadim6 x[i] <- x[i-1].jit`, N)
# use N/2 below else Error: cannot allocate vector of size 305.2 Mb
test(`x[i, 1]`, `x[i,1].comp`, `x[i,1].jit`, N/2)
cat("\n")
x <- 1:2e5
test(luke.la1.wrapper, luke.la1.wrapper.comp, luke.la1.wrapper.jit, N)
test(luke.la2.wrapper, luke.la2.wrapper.comp, luke.la2.wrapper.jit, N)
cat("\n")
ZLEN <- if (QUICK.FLAG) 1e3 else 5e3
z <- rep(c(1,1,0,0,0,0), ZLEN)
test(dirk1, dirk1.comp, dirk1.jit, ZLEN)
ZLEN <- if (QUICK.FLAG) 1e5 else 3e5
z <- rep(c(1,1,0,0,0,0), ZLEN)
test(dirk2, dirk2.comp, dirk2.jit, ZLEN)
To Ra homepage