ra.png

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