Commit 813a0626 authored by Florian Gerber's avatar Florian Gerber

v 0.7-4

parent 429f01ef
Package: optimParallel
Type: Package
Title: Parallel Versions of the Gradient-Based optim() Methods
Version: 0.7-3
Date: 2018-07-27
Version: 0.7-4
Date: 2018-10-15
Author: Florian Gerber
Maintainer: Florian Gerber <florian.gerber@math.uzh.ch>
Description: Provides parallel versions of the gradient-based optim() methods. The main function of the package is optimParallel(), which has the same usage and output as optim(). Using optimParallel() can significantly reduce the optimization time.
......
- version 0.7-3:
- version 0.7-4: bug fix
commit
Author: Florian Gerber <florian.gerber@math.uzh.ch>
Date: Mon Oct 15 22:40:37 2018 -0600
(1) 'fn'. 'gr' can now be functions from other packages
calling compiled code, e.g.,
optimParallel(par=1, fn=dnorm, mean=3)
- version 0.7-3: bug fix
commit 01ebb9016000a7b087c01b190db0b7ab9d4778d6
Author: Florian Gerber <florian.gerber@math.uzh.ch>
Date: Fri Jul 27 22:40:37 2018 -0600
......
integrateArgs <- function(f, args){
form <- formals(f)
if(!is.null(form))
for(i in seq_along(form))
assign(names(form)[i], form[[i]])
if(!is.null(args))
for(i in seq_along(args))
assign(names(args)[i], args[[i]])
ff <- function(){}
parent.env(environment(ff)) <- .GlobalEnv
body(ff) <- body(f)
if(any(names(form) == "..."))
formals(ff) <- form[names(form) == "..."]
ff
integrateArgs <- function(f, args) {
if(is.null(formals(f))) ## like sin()
args <- args[1]
else if (all(names(formals(f)) != "..."))
args <- args[names(args) %in% names(formals(f))]
do.call(function (f, ...){
# inspired from purrr::partial()
eval(call("function", NULL, substitute(f(...))),
envir=environment(f))
}, c(f=list(f), args))
##do.call(purrr::partial, c(list(f), args))
}
getFunctions <- function(f, args, firstArg, parnames){
getFunctions <- function(f,
args, ## potential other arguments
firstArg, ## first argument
parnames){
if(is.vector(firstArg))
firstArg <- matrix(data=firstArg)
lapply(seq_len(ncol(firstArg)), function(x){
fa <- firstArg[,x]
names(fa) <- parnames
args[[names(formals(f))[1]]] <- fa
integrateArgs(f=f, args=args)
args <- args[names(args) != names(formals(args(f)))[1]]
allargs <- c(list(fa), args)
names(allargs)[1] <- names(formals(args(f)))[1]
integrateArgs(f=f, args=allargs)
})
}
......
......@@ -16,7 +16,8 @@
#' Note that depending on the chosen cluster type for parallel execution, the \code{.GlobalEnv} of the R processes in the cluster contain different R objects compared to the main R process.
#' In that case, it may be necessary to add all R object required by \code{fn} and \code{gr} here in order to pass them to the R processes in the cluster.
#' @param method parallel versions of the gradient-based methods \code{"L-BFGS-B"} (default), \code{"BFGS"}, and \code{"CG"} of \code{\link[stats]{optim}} are available.
#' See the documentation of \code{\link[stats]{optim}} for information on those methods.
#' The recommended method is \code{"L-BFGS-B"} because it triggers one (approximate) gradient evaluation per iteration, which best fits the implemented parallel processing scheme.
#' See the documentation of \code{\link[stats]{optim}} for information on the methods.
#' If another method is specified, all arguments are directly passed to \code{\link[stats]{optim}}.
#' @param lower see the documentation of \code{\link[stats]{optim}}.
#' @param upper see the documentation of \code{\link[stats]{optim}}.
......@@ -140,9 +141,12 @@ optimParallel <- function(par, fn, gr = NULL, ..., method = c("L-BFGS-B", "BFGS"
lower = -Inf, upper = Inf, control = list(), hessian = FALSE,
parallel=list()){
dots <- list(...)
if(!identical(dots, list()) && (any(names(formals(args(fn)))[1]==names(dots)) || any(names(formals(args(fn)))[1]==names(dots))))
warning("The first argument of \"fn\" and/or \"gr\" has the same name as one argument passed through \"...\". The value passed through \"...\" for that argument is ignored.")
method <- method[1]
if(!(method %in% c("BFGS", "L-BFGS-B", "CG"))){
warning("Only the gradient methods \"BFGS\", \"L-BFGS-B\", and \"CG\" are available in a parallel version.")
if(!(method %in% c("L-BFGS-B", "BFGS", "CG"))){
warning("Only the gradient methods \"L-BFGS-B\", \"BFGS\", and \"CG\" are available in a parallel version.")
return(optim(par=par, fn=fn, gr=gr, ..., method=method,
lower=lower, upper=upper, control=list(), hessian=FALSE))
}
......
......@@ -29,7 +29,8 @@ Note that depending on the chosen cluster type for parallel execution, the \code
In that case, it may be necessary to add all R object required by \code{fn} and \code{gr} here in order to pass them to the R processes in the cluster.}
\item{method}{parallel versions of the gradient-based methods \code{"L-BFGS-B"} (default), \code{"BFGS"}, and \code{"CG"} of \code{\link[stats]{optim}} are available.
See the documentation of \code{\link[stats]{optim}} for information on those methods.
The recommended method is \code{"L-BFGS-B"} because it triggers one (approximate) gradient evaluation per iteration, which best fits the implemented parallel processing scheme.
See the documentation of \code{\link[stats]{optim}} for information on the methods.
If another method is specified, all arguments are directly passed to \code{\link[stats]{optim}}.}
\item{lower}{see the documentation of \code{\link[stats]{optim}}.}
......
optimParallel:::integrateArgs
optimParallel:::integrateArgs
optimParallel:::integrateArgs
optimParallel:::integrateArgs
library("optimParallel")
optimParallel:::integrateArgs
optimParallel:::integrateArgs
optimParallel:::getFunctions
library("optimParallel")
library("optimParallel")
install.packages("testhat")
install.packages("testthat")
library("optimParallel")
library(spam)
spam(1:4, 2)
diag(spam(1:4, 2))
diag(spam(1:4, 2))
FN4(c(1,2))
file.show("testsetup.R")
library("optimParallel")
.GlobalEnv
ls()
ls(all=TRUE)
......@@ -5,6 +5,9 @@ source("testsetup.R")
context("test-issues")
control <- structure(list(maxit = 10,
factr = 2.22044604925031e-16),
.Names = c("maxit","factr"))
FN1 <- function(par, sleep){
Sys.sleep(sleep)
......@@ -19,9 +22,7 @@ GR1 <- function(par, sleep){
test_that("optimParallel",{
compareOptim(list(par=c(1,2,3), fn=FN1, gr=GR1, sleep=0,
method = "L-BFGS-B",
control=structure(list(maxit = 10,
factr = 2.22044604925031e-16),
.Names = c("maxit","factr"))),
control=control),
verbose=verbose)
})
......@@ -46,39 +47,41 @@ GR3 <- function(par, sleep){
test_that("optimParallel - named arguments",{
compareOptim(list(par=c(a=1,b=2), fn=FN2, sleep=0,
method = "L-BFGS-B",
control=structure(list(maxit = 10,
factr = 2.22044604925031e-16),
.Names = c("maxit","factr"))),
control=control),
verbose=verbose)
compareOptim(list(par=c(a=1,b=2), fn=FN2, gr= GR2, sleep=0,
method = "L-BFGS-B",
control=structure(list(maxit = 10,
factr = 2.22044604925031e-16),
.Names = c("maxit","factr"))),
control=control),
verbose=verbose)
compareOptim(list(par=c(a=1), fn=FN3, sleep=0,
method = "L-BFGS-B",
control=structure(list(maxit = 10,
factr = 2.22044604925031e-16),
.Names = c("maxit","factr"))),
control=control),
verbose=verbose)
compareOptim(list(par=c(a=1), fn=FN3, gr= GR3, sleep=0,
method = "L-BFGS-B",
control=structure(list(maxit = 10,
factr = 2.22044604925031e-16),
.Names = c("maxit","factr"))),
control=control),
verbose=verbose)
})
FN4 <- function(par){
print(search())
diag(spam(1:4, 2))
sum(par^2)
}
test_that("optimParallel - use compiled code from other packages",{
compareOptim(list(par=1, fn=abs, method = "L-BFGS-B",
control=control),
verbose=verbose)
expect_equal(optimParallel(par=1, fn=abs, aflaf=1, method = "L-BFGS-B"),
optim(par=1, fn=abs, method = "L-BFGS-B"))
compareOptim(list(par=1, fn=abs, gr=abs, method = "L-BFGS-B",
control=control),
verbose=verbose)
expect_equal(optimParallel(par=1, fn=abs, gr=abs, aflaf=1, method = "L-BFGS-B"),
optim(par=1, fn=abs, gr=abs, method = "L-BFGS-B"))
test_that("optimParallel - dispatch to other packages",{
skip_if_not(require("spam"), message="spam not available for testing dispatching to loaded packages")
clusterEvalQ(cl, require("spam"))
expect_true({optimParallel(par=c(a=1,b=2), fn=FN4, method = "L-BFGS-B"); TRUE})
compareOptim(list(par=1, fn=dnorm, method = "L-BFGS-B",
control=control),
verbose=verbose)
compareOptim(list(par=1, fn=dnorm, mean=3, method = "L-BFGS-B",
control=control),
verbose=verbose)
expect_equal(optimParallel(par=1, fn=dnorm, mean=2, aflaf=1, method = "L-BFGS-B"),
optim(par=1, fn=dnorm, mean=2, method = "L-BFGS-B"))
})
......@@ -42,6 +42,12 @@ f6 <- function(par){
par[1]^2+(1-par[2])^2
}
f7 <- function(x, ...){
dots <- list(...)
if(!identical(dots, list()))
return(sum((x-dots[[1]])^2))
sum(x^2)
}
test_that("optimParallel",{
compareOptim(list(par=c(2,1), fn=f1, x=x, method = "L-BFGS-B",
......@@ -195,3 +201,17 @@ test_that("method = BFGS and CG",{
control=list(factr=factr), a=1),
verbose=verbose)
})
test_that("fn can have ... arguments",{
compareOptim(list(par=2, fn=f7, method = "L-BFGS-B",
control=list(factr=factr)),
verbose=verbose)
compareOptim(list(par=2, fn=f7, kjvasfa=4, method = "L-BFGS-B",
control=list(factr=factr)),
verbose=verbose)
expect_warning(optimParallel(par=2, fn=f7, x=2, control=list(factr=factr)),
"has the same name as one argument passed through")
})
## rm(list=ls())
## library("testthat")
## library("optimParallel", lib.loc = "../../../lib/")
source("testsetup.R")
context("test-spam")
control <- structure(list(maxit = 10,
factr = 2.22044604925031e-16),
.Names = c("maxit","factr"))
test_that("optimParallel - mle.spam",{
skip_if_not(require("spam"), message="spam not available for testing dispatching to loaded packages")
clusterEvalQ(cl, require("spam"))
truebeta <- c(1,2,.2)
truetheta <- c(.5,2,.02)
x <- seq(0,1,l=5)
locs <- expand.grid(x, x)
X <- as.matrix(cbind(1,locs))
distmat <- nearest.dist( locs, upper=NULL)
Sigma <- cov.sph(distmat, truetheta)
set.seed(15)
y <- c(rmvnorm.spam(1, X %*% truebeta, Sigma))
mle_optimParallel <- function (y, X, distmat, Covariance, beta0, theta0, thetalower,
thetaupper, optim.control = NULL, Rstruct = NULL, hessian = FALSE,
...)
{
if (!is(Rstruct, "spam.chol.NgPeyton")) {
Sigma <- do.call(Covariance, list(distmat, c(thetaupper[1],
theta0[-1])))
if (!is.spam(Sigma))
stop("\"Covariance\" should return a spam object.")
Rstruct <- chol.spam(Sigma, ...)
}
p <- dim(X)[2]
n <- length(y)
neg2loglikelihood <- function(fulltheta, ...) {
Sigma <- do.call(Covariance, list(distmat, fulltheta[-(1:p)]))
cholS <- update.spam.chol.NgPeyton(Rstruct, Sigma, ...)
resid <- y - X %*% fulltheta[1:p]
return(n * log(2 * pi) + 2 * c(determinant.spam.chol.NgPeyton(cholS)$modulus) +
sum(resid * solve.spam(cholS, resid)))
}
return(optimParallel(c(beta0, theta0), neg2loglikelihood, method = "L-BFGS-B",
control = optim.control, lower = c(rep(-Inf, p), thetalower),
upper = c(rep(Inf, p), thetaupper), hessian = hessian))
}
expect_equal(mle.spam(y, X, distmat, cov.sph,
truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)),
mle_optimParallel(y, X, distmat, cov.sph,
truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)))
})
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment