tests/compTest.R

In RcppDE: Global Optimization by Differential Evolution in C++

Wild <- function(x) { 		## 'Wild' function, global minimum at about -15.81515
    sum(10 * sin(0.3 * x) * sin(1.3 * x^2) + 0.00001 * x^4 + 0.2 * x + 80)/length(x)
}

Rastrigin <- function(x) {
    sum(x+2 - 10 * cos(2*pi*x)) + 20
}

Genrose <- function(x, a = 1, b = 100) { 	## One generalization of the Rosenbrock banana valley function (n parameters)
    n <- length(x)
    1.0 + sum (b * (x[-n]^2 - x[-1])^2 + (x[-1] - a)^2)
}

maxIt <- 25         		# not excessive but so that we get some run-time on simple problems

haveDEoptim <- requireNamespace("DEoptim", quietly=TRUE)

suppressMessages({
    if (haveDEoptim) {
        library(DEoptim) 	# the original, currently 2.0.7
    }
    library(RcppDE) 		# the contender
})

basicDE <- function(n, maxIt, fun, ...) DEoptim::DEoptim(fn=fun, lower=rep(-25, n), upper=rep(25, n),
                                                         control=list(NP=10*n, itermax=maxIt, trace=FALSE),
                                                         ...)#, bs=TRUE))
cppDE <- function(n, maxIt, fun, ...) RcppDE::DEoptim(fn=fun, lower=rep(-25, n), upper=rep(25, n),
                                                      control=list(NP=10*n, itermax=maxIt, trace=FALSE),
                                                      ...)#, bs=TRUE))

if (haveDEoptim) {
    set.seed(42)
    valBasic <- basicDE(5, maxIt, function(...) Rastrigin(...))
    set.seed(42)
    valCpp <- cppDE(5, maxIt, function(...) Rastrigin(...))
    ##stopifnot( all.equal(valBasic, valCpp) )
}

runPair <- function(n, maxIt, fun, funname, ...) {
    gc()
    set.seed(42)
    bt <- system.time(invisible(ores <- basicDE(n, maxIt, fun, ...)))[3]

    gc()
    set.seed(42)
    xptr <- RcppDE:::putFunPtrInXPtr(funname)
    ct <- system.time(invisible(cres <- cppDE(n, maxIt, xptr, ...)))[3]

    #stopifnot(all.equal(ores, cres))

    gc()
    set.seed(42)
    rt <- system.time(invisible(rres <- cppDE(n, maxIt, fun, ...)))[3]

    ##stopifnot(all.equal(ores, rres))

    return(data.frame(DEoptim=bt, RcppDEc=ct, RcppDEr=rt))
}

if (haveDEoptim) {

    cat("# At", format(Sys.time()), "\n")
    options(width=120)

    reps <- c(5, 10, 20, 50)

    res <- rbind(do.call(rbind, lapply(reps, runPair, maxIt, function(...) Rastrigin(...), "rastrigin")),
                 do.call(rbind, lapply(reps, runPair, maxIt, function(...) Wild(...), "wild")),
                 do.call(rbind, lapply(reps, runPair, maxIt, function(...) Genrose(...), "genrose", a = 1, b = 100))
                 )
    res <- rbind(res, colMeans(res))

    rownames(res) <- c(paste("Rastrigin", reps, sep=""),
                       paste("Wild", reps, sep=""),
                       paste("Genrose", reps, sep=""),
                       "MEANS")

    res$ratioRcppCompToBasic <- res[,2]/res[,1]
    res$pctGainOfRcppComp <- (1-res[,2]/res[,1])*100
    ##res$netSpeedUpC <- res[,1]/res[,2]

    res$ratioRcppRToBasic <- res[,3]/res[,1]
    res$pctGainOfRcppR <- round((1-res[,3]/res[,1])*100, digits=3)
    ##res$netSpeedUpR <- res[,1]/res[,3]


    print(res)
    cat("# Done", format(Sys.time()), "\n")
}