void nimble_optim_withVarArgs(void* nimFun, OptimControl* control, OptimAns* ans,
NimArr<1, double> par, optimfn objFxn,
int numOtherArgs, ...){
//Steps required:
//Unpack parts of control (things that are required for all optimizers)
//Decide optimizer {
//Based on optimizer, unpack specialized part of optimControl and call appropriate optimizer
// unpack results of optimizer into ans
// }
// ?return ans (depends if we want to allow return of nimble functions)
// Generic Unpacking
int n = par.size();
double* xin = &(par[0]); //IF we want to leave par untouched by optim, we could copy these values instead of pointing at them
double* x = &(ans->par[0]);
double* Fmin = &(ans->Fmin);
int* fail = &(ans->fail);
int* fncount = &(ans->fncount);
vector<void*>* otherArgs = new vector<void*>(numOtherArgs);
va_list vl;
va_start(vl, numOtherArgs);
for(int i = 0; i < numOtherArgs; i++)
(*otherArgs)[i] = va_arg(vl, void*);
va_end(vl);
vector<void*>* ex = new vector<void*> (2);
(*ex)[0] = nimFun;
(*ex)[1] = otherArgs;
//Choosing and applying optimizer
//Just using Nelder Mead as example here
if( control->optimType == 1 ){
NM_OptimControl* nmControl = static_cast<NM_OptimControl*>(control);
nmmin(n, xin, x, Fmin, objFxn, fail, nmControl->abstol, nmControl->intol,
static_cast<void*> (ex), nmControl->alpha, nmControl->beta, nmControl->gamma, nmControl->trace,
fncount, nmControl->maxit);
}
delete ex;
delete otherArgs;
//actually, nothing else to do at this point!
//Could return ans if we decided to build it on the fly here instead of providing it as argument
}
void geod_xy_inverse(int *n,
double *x, /* input vector of x values */
double *y, /* input vector of y values */
double *latr, /* single reference latitude */
double *lonr, /* single reference longitude */
double *a, /* WGS84 major axis 6378137.00 */
double *f, /* WGS84 flattening parameter 1/298.257223563 */
double *longitude, double *latitude) /* output */
{
//Rprintf("%3s %10s %10s %10s %10s %10s %10s [geod_xy_inverse]\n", "i", "x", "y", "lon.ref", "lat.ref", "xin[0]", "xin[1]");
for (int i = 0; i < *n; i++) {
double xin[2];
double ex[4]; // x, y, lonr, latr
ex[0] = x[i];
ex[1] = y[i];
ex[2] = *lonr;
ex[3] = *latr;
int fail=0;
// Re the two tolerances: 1e-5 in lat or lon is 1m in space
double abstol=1.0e-6;
double intol=1.0e-6;
xin[1] = y[i] / 111e3;
xin[0] = x[i] / 111e3 / cos(xin[1]*M_PI/180.0);
//Rprintf("%3d %10.0f %10.0f %10.2f %10.2f %10.2f %10.2f [geod_xy_inverse]\n", i, ex[0], ex[1], ex[2], ex[3], xin[0], xin[1]);
double alpha=1.0, beta=0.5, gamma=2.0;
double xout[2];
double Fmin=0.0;
int trace=0, fncount=0, maxit=500;
int nn=2;
nmmin(nn, xin, xout, &Fmin,
lonlat_misfit,
&fail, abstol, intol, (void*)ex,
alpha, beta, gamma, trace,
&fncount, maxit);
longitude[i] = xout[0];
latitude[i] = xout[1];
//Rprintf(" ... fncount=%d Fmin=%f\n", fncount, Fmin);
}
}
void maximizePrecisionUnpaired(void * inputs, double * prev_val, double * x,
bool share_nu_alpha) {
// starting location
precPtrsUnpaired * ex = static_cast<precPtrsUnpaired * >(inputs);
int p = ex->p;
int n_pep = ex->n_peptide;
int n_trt = ex->n_trt;
double TAU_CHECK_VAL = 1.0e-15;
double tau_sum(0.0);
bool orig_share = share_nu_alpha;
for (int i = 0; i < n_trt; i++) {
tau_sum += ex->tau[n_pep * i + p];
}
if ((tau_sum < TAU_CHECK_VAL) && !share_nu_alpha) {
ex->share_nu_alpha = true;
share_nu_alpha = true;
}
double par[3];
double par_out[3];
int n;
par[0] = log(prev_val[0]);
par[1] = log(prev_val[1]);
if (share_nu_alpha) {
par[2] = log(prev_val[1]);
n = 2;
} else {
par[2] = log(prev_val[2]);
n = 3;
}
// misc tuning parameters and reporting parameters
int maxit(100), fncount, fail, trace(0);
double Fmin, abstol(- INFINITY), intol(1.0e-4);
double alpha(1.0), beta(.5), gamma(2.0);
nmmin(n, par, par_out, &Fmin, precisionObjectiveFnUnpaired,
&fail, abstol, intol, inputs, alpha, beta, gamma, trace,
&fncount, maxit);
if (fail > 0) {
x[0] = prev_val[0];
x[1] = prev_val[1];
if (share_nu_alpha) {
x[2] = prev_val[1];
} else {
x[2] = prev_val[2];
}
return;
}
x[0] = exp(par_out[0]);
x[1] = exp(par_out[1]);
if (share_nu_alpha) {
x[2] = exp(par_out[1]);
} else {
x[2] = exp(par_out[2]);
}
if ((tau_sum < TAU_CHECK_VAL) && (!orig_share)) {
x[2] = sqrt(DBL_MIN);
}
return;
}
// This attempts to match the behavior of optim() defined in the documentation
// https://stat.ethz.ch/R-manual/R-devel/library/stats/html/optim.html
// and in the reference implementation
// https://svn.r-project.org/R/trunk/src/library/stats/R/optim.R
// https://svn.r-project.org/R/trunk/src/library/stats/src/optim.c
// https://svn.r-project.org/R/trunk/src/include/R_ext/Applic.h
nimSmartPtr<OptimResultNimbleList> NimOptimProblem::solve(
NimArr<1, double>& par) {
NIM_ASSERT1(!par.isMap(), "Internal error: failed to handle mapped NimArr");
const int n = par.dimSize(0);
nimSmartPtr<OptimResultNimbleList> result = new OptimResultNimbleList;
result->par = par;
result->counts.initialize(NA_INTEGER, true, 2);
if (hessian_) {
result->hessian.initialize(NA_REAL, true, n, n);
}
// Set context-dependent default control_ values.
if (control_->maxit == NA_INTEGER) {
if (method_ == "Nelder-Mead") {
control_->maxit = 500;
} else {
control_->maxit = 100;
}
}
// Parameters common to all methods.
double* dpar = par.getPtr();
double* X = result->par.getPtr();
double* Fmin = &(result->value);
int* fail = &(result->convergence);
void* ex = this;
int* fncount = &(result->counts[0]);
int* grcount = &(result->counts[1]);
if (method_ == "Nelder-Mead") {
nmmin(n, dpar, X, Fmin, NimOptimProblem::fn, fail, control_->abstol,
control_->reltol, ex, control_->alpha, control_->beta,
control_->gamma, control_->trace, fncount, control_->maxit);
} else if (method_ == "BFGS") {
std::vector<int> mask(n, 1);
vmmin(n, dpar, Fmin, NimOptimProblem::fn, NimOptimProblem::gr,
control_->maxit, control_->trace, mask.data(), control_->abstol,
control_->reltol, control_->REPORT, ex, fncount, grcount, fail);
result->par = par;
} else if (method_ == "CG") {
cgmin(n, dpar, X, Fmin, NimOptimProblem::fn, NimOptimProblem::gr, fail,
control_->abstol, control_->reltol, ex, control_->type,
control_->trace, fncount, grcount, control_->maxit);
} else if (method_ == "L-BFGS-B") {
if (lower_.dimSize(0) == 1) lower_.initialize(lower_[0], true, n);
if (upper_.dimSize(0) == 1) upper_.initialize(upper_[0], true, n);
NIM_ASSERT_SIZE(lower_, n);
NIM_ASSERT_SIZE(upper_, n);
std::vector<int> nbd(n, 0);
for (int i = 0; i < n; ++i) {
if (std::isfinite(lower_[i])) nbd[i] |= 1;
if (std::isfinite(upper_[i])) nbd[i] |= 2;
}
char msg[60];
lbfgsb(n, control_->lmm, X, lower_.getPtr(), upper_.getPtr(),
nbd.data(), Fmin, NimOptimProblem::fn, NimOptimProblem::gr, fail,
ex, control_->factr, control_->pgtol, fncount, grcount,
control_->maxit, msg, control_->trace, control_->REPORT);
result->message = msg;
} else {
NIMERROR("Unknown method_: %s", method_.c_str());
}
result->value *= control_->fnscale;
// Compute Hessian.
if (hessian_) {
Rf_warning("Hessian computation is not implemented"); // TODO
}
return result;
}
/* par fn gr method options */
SEXP optim(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP par, fn, gr, method, options, tmp, slower, supper;
SEXP res, value, counts, conv;
int i, npar=0, *mask, trace, maxit, fncount = 0, grcount = 0, nREPORT, tmax;
int ifail = 0;
double *dpar, *opar, val = 0.0, abstol, reltol, temp;
const char *tn;
OptStruct OS;
PROTECT_INDEX par_index;
args = CDR(args);
OS = (OptStruct) R_alloc(1, sizeof(opt_struct));
OS->usebounds = 0;
OS->R_env = rho;
par = CAR(args);
OS->names = getAttrib(par, R_NamesSymbol);
args = CDR(args); fn = CAR(args);
if (!isFunction(fn)) error(_("'fn' is not a function"));
args = CDR(args); gr = CAR(args);
args = CDR(args); method = CAR(args);
if (!isString(method)|| LENGTH(method) != 1)
error(_("invalid '%s' argument"), "method");
tn = CHAR(STRING_ELT(method, 0));
args = CDR(args); options = CAR(args);
PROTECT(OS->R_fcall = lang2(fn, R_NilValue));
PROTECT_WITH_INDEX(par = coerceVector(par, REALSXP), &par_index);
if (MAYBE_REFERENCED(par))
REPROTECT(par = duplicate(par), par_index);
npar = LENGTH(par);
dpar = vect(npar);
opar = vect(npar);
trace = asInteger(getListElement(options, "trace"));
OS->fnscale = asReal(getListElement(options, "fnscale"));
tmp = getListElement(options, "parscale");
if (LENGTH(tmp) != npar)
error(_("'parscale' is of the wrong length"));
PROTECT(tmp = coerceVector(tmp, REALSXP));
OS->parscale = vect(npar);
for (i = 0; i < npar; i++) OS->parscale[i] = REAL(tmp)[i];
UNPROTECT(1);
for (i = 0; i < npar; i++)
dpar[i] = REAL(par)[i] / (OS->parscale[i]);
PROTECT(res = allocVector(VECSXP, 5));
SEXP names;
PROTECT(names = allocVector(STRSXP, 5));
SET_STRING_ELT(names, 0, mkChar("par"));
SET_STRING_ELT(names, 1, mkChar("value"));
SET_STRING_ELT(names, 2, mkChar("counts"));
SET_STRING_ELT(names, 3, mkChar("convergence"));
SET_STRING_ELT(names, 4, mkChar("message"));
setAttrib(res, R_NamesSymbol, names);
UNPROTECT(1);
PROTECT(value = allocVector(REALSXP, 1));
PROTECT(counts = allocVector(INTSXP, 2));
SEXP countnames;
PROTECT(countnames = allocVector(STRSXP, 2));
SET_STRING_ELT(countnames, 0, mkChar("function"));
SET_STRING_ELT(countnames, 1, mkChar("gradient"));
setAttrib(counts, R_NamesSymbol, countnames);
UNPROTECT(1);
PROTECT(conv = allocVector(INTSXP, 1));
abstol = asReal(getListElement(options, "abstol"));
reltol = asReal(getListElement(options, "reltol"));
maxit = asInteger(getListElement(options, "maxit"));
if (maxit == NA_INTEGER) error(_("'maxit' is not an integer"));
if (strcmp(tn, "Nelder-Mead") == 0) {
double alpha, beta, gamm;
alpha = asReal(getListElement(options, "alpha"));
beta = asReal(getListElement(options, "beta"));
gamm = asReal(getListElement(options, "gamma"));
nmmin(npar, dpar, opar, &val, fminfn, &ifail, abstol, reltol,
(void *)OS, alpha, beta, gamm, trace, &fncount, maxit);
for (i = 0; i < npar; i++)
REAL(par)[i] = opar[i] * (OS->parscale[i]);
grcount = NA_INTEGER;
}
else if (strcmp(tn, "SANN") == 0) {
tmax = asInteger(getListElement(options, "tmax"));
temp = asReal(getListElement(options, "temp"));
if (trace) trace = asInteger(getListElement(options, "REPORT"));
if (tmax == NA_INTEGER || tmax < 1) // PR#15194
error(_("'tmax' is not a positive integer"));
if (!isNull(gr)) {
if (!isFunction(gr)) error(_("'gr' is not a function"));
PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
} else {
PROTECT(OS->R_gcall = R_NilValue); /* for balance */
}
samin (npar, dpar, &val, fminfn, maxit, tmax, temp, trace, (void *)OS);
for (i = 0; i < npar; i++)
REAL(par)[i] = dpar[i] * (OS->parscale[i]);
fncount = npar > 0 ? maxit : 1;
grcount = NA_INTEGER;
UNPROTECT(1); /* OS->R_gcall */
} else if (strcmp(tn, "BFGS") == 0) {
SEXP ndeps;
nREPORT = asInteger(getListElement(options, "REPORT"));
if (!isNull(gr)) {
if (!isFunction(gr)) error(_("'gr' is not a function"));
PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
} else {
PROTECT(OS->R_gcall = R_NilValue); /* for balance */
ndeps = getListElement(options, "ndeps");
if (LENGTH(ndeps) != npar)
error(_("'ndeps' is of the wrong length"));
OS->ndeps = vect(npar);
PROTECT(ndeps = coerceVector(ndeps, REALSXP));
for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
UNPROTECT(1);
}
mask = (int *) R_alloc(npar, sizeof(int));
for (i = 0; i < npar; i++) mask[i] = 1;
vmmin(npar, dpar, &val, fminfn, fmingr, maxit, trace, mask, abstol,
reltol, nREPORT, (void *)OS, &fncount, &grcount, &ifail);
for (i = 0; i < npar; i++)
REAL(par)[i] = dpar[i] * (OS->parscale[i]);
UNPROTECT(1); /* OS->R_gcall */
} else if (strcmp(tn, "CG") == 0) {
int type;
SEXP ndeps;
type = asInteger(getListElement(options, "type"));
if (!isNull(gr)) {
if (!isFunction(gr)) error(_("'gr' is not a function"));
PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
} else {
PROTECT(OS->R_gcall = R_NilValue); /* for balance */
ndeps = getListElement(options, "ndeps");
if (LENGTH(ndeps) != npar)
error(_("'ndeps' is of the wrong length"));
OS->ndeps = vect(npar);
PROTECT(ndeps = coerceVector(ndeps, REALSXP));
for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
UNPROTECT(1);
}
cgmin(npar, dpar, opar, &val, fminfn, fmingr, &ifail, abstol,
reltol, (void *)OS, type, trace, &fncount, &grcount, maxit);
for (i = 0; i < npar; i++)
REAL(par)[i] = opar[i] * (OS->parscale[i]);
UNPROTECT(1); /* OS->R_gcall */
} else if (strcmp(tn, "L-BFGS-B") == 0) {
SEXP ndeps, smsg;
double *lower = vect(npar), *upper = vect(npar);
int lmm, *nbd = (int *) R_alloc(npar, sizeof(int));
double factr, pgtol;
char msg[60];
nREPORT = asInteger(getListElement(options, "REPORT"));
factr = asReal(getListElement(options, "factr"));
pgtol = asReal(getListElement(options, "pgtol"));
lmm = asInteger(getListElement(options, "lmm"));
if (!isNull(gr)) {
if (!isFunction(gr)) error(_("'gr' is not a function"));
PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
} else {
PROTECT(OS->R_gcall = R_NilValue); /* for balance */
ndeps = getListElement(options, "ndeps");
if (LENGTH(ndeps) != npar)
error(_("'ndeps' is of the wrong length"));
OS->ndeps = vect(npar);
PROTECT(ndeps = coerceVector(ndeps, REALSXP));
for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
UNPROTECT(1);
}
args = CDR(args); slower = CAR(args); /* coerce in calling code */
args = CDR(args); supper = CAR(args);
for (i = 0; i < npar; i++) {
lower[i] = REAL(slower)[i] / (OS->parscale[i]);
upper[i] = REAL(supper)[i] / (OS->parscale[i]);
if (!R_FINITE(lower[i])) {
if (!R_FINITE(upper[i])) nbd[i] = 0; else nbd[i] = 3;
} else {
if (!R_FINITE(upper[i])) nbd[i] = 1; else nbd[i] = 2;
}
}
OS->usebounds = 1;
OS->lower = lower;
OS->upper = upper;
lbfgsb(npar, lmm, dpar, lower, upper, nbd, &val, fminfn, fmingr,
&ifail, (void *)OS, factr, pgtol, &fncount, &grcount,
maxit, msg, trace, nREPORT);
for (i = 0; i < npar; i++)
REAL(par)[i] = dpar[i] * (OS->parscale[i]);
UNPROTECT(1); /* OS->R_gcall */
PROTECT(smsg = mkString(msg));
SET_VECTOR_ELT(res, 4, smsg);
UNPROTECT(1);
} else
error(_("unknown 'method'"));
if(!isNull(OS->names)) setAttrib(par, R_NamesSymbol, OS->names);
REAL(value)[0] = val * (OS->fnscale);
SET_VECTOR_ELT(res, 0, par); SET_VECTOR_ELT(res, 1, value);
INTEGER(counts)[0] = fncount; INTEGER(counts)[1] = grcount;
SET_VECTOR_ELT(res, 2, counts);
INTEGER(conv)[0] = ifail;
SET_VECTOR_ELT(res, 3, conv);
UNPROTECT(6);
return res;
}
