void
VR_dovm(Sint *ntr, Sdata *train, Sdata *weights,
Sint *Nw, double *wts, double *Fmin,
Sint *maxit, Sint *trace, Sint *mask,
double *abstol, double *reltol, int *ifail)
{
int fncount, grcount;
NTrain = *ntr;
TrainIn = train;
TrainOut = train + Ninputs * NTrain;
Weights = weights;
vmmin((int) *Nw, wts, Fmin, fminfn, fmingr,
(int) *maxit, (int) *trace, mask,
*abstol, *reltol, REPORT, NULL, &fncount, &grcount, ifail);
}
void maximizeTnormHypers(const double * data, int data_len, const double m_mean,
const double m_prec, const double nu_rate, const double nu_shape,
double * x) {
// inside betaHyperObjectiveFn:
// const double beta1_sum(input[0]);
// const double beta1_sqr_sum(input[1]);
// const double P(input[2]);
// const double l1(input[3]);
// const double s1(input[4]);
// const double m_bar(input[5]);
// const double nu_m(input[6]);
double input[7];
input[0] = 0.0;
input[1] = 0.0;
for (int j = 0; j < data_len; j++) {
input[0] += data[j];
input[1] += data[j] * data[j];
}
input[2] = (double) data_len;
input[3] = nu_rate;
input[4] = nu_shape;
input[5] = m_mean;
input[6] = m_prec;
// initial guess for location and (log) inverse-scale;
double par[2];
par[0] = input[0] / input[2];
par[1] = - log(1.0 + input[1] / input[2] - par[0] * par[0]);
// misc BFGS tuning parameters and reporting parameters
int n(2), report(10), maxit(100), fncount, grcount, fail, trace(0);
int mask[2] = {1, 1};
double Fmin, abstol(- INFINITY), reltol(1.0e-8);
vmmin(n, par, &Fmin, betaHyperObjectiveFn, betaHyperObjectiveGr,
maxit, trace, mask, abstol, reltol, report, (void *) input,
&fncount, &grcount, &fail);
if (fail > 0)
return;
x[0] = par[0];
x[1] = exp(par[1]);
}
void maximizeGammaHypers(const double * data, int data_len, const double l_s,
const double l_lambda, double * x) {
// inside gammaHyperObjectiveFn:
// const double sum_log_x(input[0]);
// const double sum_x(input[1]);
// const double P(input[2]);
// const double l_s(input[3]);
// const double l_l(input[4]);
double input[5];
input[0] = 0.0;
input[1] = 0.0;
for(int j = 0; j < data_len; j++) {
input[0] += log(data[j]);
input[1] += data[j];
}
input[2] = (double) data_len;
input[3] = l_s;
input[4] = l_lambda;
// initial guess for max of shape (pretty good, actually)
double par, s = log(input[1] / input[2]) - input[0] / input[2];
s = ((3 - s) + sqrt((s - 3) * (s - 3) + 24.0 * s)) / (12 * s);
par = s;
// misc BFGS tuning parameters and reporting parameters
int n(1), mask(1), report(10), maxit(100), fncount, grcount, fail, trace(0);
double Fmin, abstol(- INFINITY), reltol(1.0e-8);
vmmin(n, &par, &Fmin, gammaHyperObjectiveFn, gammaHyperObjectiveGr,
maxit, trace, &mask, abstol, reltol, report, (void *) input,
&fncount, &grcount, &fail);
// optimization failed for some reason; return good guess
if (fail > 0)
par = s;
x[0] = par;
x[1] = input[2] * par / (l_lambda + input[1]);
return;
}
void expsup(int *iter, double *eps, int *printlevel,
int *nn, int *ncov, int *bdim,
double *time0, double *time, int * ind,
double *covar, double *offset, double *shape,
double *init, double *beta, double *lambda, double *lambda_sd,
double *loglik, double *dloglik, double *variance, double *sctest,
int *conver, int *fail){
Exts *ex;
int ord, i, j;
int iok;
int maxiter;
int trace;
int *mask;
int events;
int nREPORT = 1;
int fncount, grcount;
int ipfixed = 1;
double Fmin;
double zb, s, d, ap, bdz;
ex = (Exts *)R_alloc(1, sizeof(Exts));
mask = (int *)R_alloc(*bdim, sizeof(int));
for (i = 0; i < *bdim; i++){
mask[i] = 1;
}
maxiter = 1000;
trace = *printlevel;
iok = 0;
/* Fill in 'ex': */
ex->pfix = shape;
ex->mb = ncov;
ex->nn = nn;
ex->z = covar;
ex->time0 = time0;
ex->time = time;
ex->ind = ind;
ex->offset = offset;
ex->iok = &iok;
for (i = 0; i < *ncov; i++) beta[i] = init[i];
*lambda = 0.0;
events = 0;
for (i = 0; i < *nn; i++){
zb = offset[i];
for (j = 0; j < *ncov; j++){
zb += beta[j] * covar[j + i * (*ncov)];
}
*lambda += exp(zb) * (time[i] - time0[i]);
events += ind[i];
}
if (events <= 0) error("No events\n");
if (*lambda <= 0.0) error("No (or negative) exposure time!\n");
*lambda = (double)events / *lambda;
beta[*ncov] = log(*lambda);
Fmin = 0.0;
s = 0.0;
d = 0.0;
bdz = 0.0;
ap = log(*lambda);
for (i = 0; i < *nn; i++){
zb = offset[i];
for (j = 0; j < *ncov; j++){
if (ind[i])
bdz += beta[j] * covar[j + i * (*ncov)];
zb += beta[j] * covar[j + i * (*ncov)];
}
s += *lambda * exp(zb) * (time[i] - time0[i]);
d += ind[i];
Fmin += ind[i] * (ap + zb);
Fmin -= *lambda * exp(zb) * (time[i] - time0[i]);
}
ord = 0; /* get initial loglik value in 'loglik[0]' */
F77_CALL(wfunc)(&ord, &ipfixed, ex->pfix, bdim, ex->mb, beta,
ex->nn, ex->z, ex->time0, ex->time, ex->ind, ex->offset,
&Fmin, dloglik, variance, ex->iok);
loglik[0] = -Fmin; /* NOTE! */
vmmin(*bdim, beta, &Fmin,
e_fun, ge_fun, maxiter, trace,
mask, *eps, *eps, nREPORT,
ex, &fncount, &grcount, fail);
loglik[1] = -Fmin;
ord = 2;
F77_CALL(wfunc)(&ord, &ipfixed, ex->pfix, bdim, ex->mb, beta,
ex->nn, ex->z, ex->time0, ex->time, ex->ind, ex->offset,
&Fmin, dloglik, variance, ex->iok);
F77_CALL(expnr)(iter, eps, printlevel, nn, ncov, bdim,
time0, time, ind, covar, offset, shape,
beta, lambda, lambda_sd, &Fmin, dloglik,
variance,
conver, fail);
loglik[1] = Fmin;
}
// 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;
}