void rankSample(NimArr<1, double> &weights, int &n, NimArr<1, int> &output, bool& silent) {
//PRINTF("in VOID rankSample\n");
output.setSize(n);
int N = weights.size();
//GetRNGstate();
rawSample(weights.getPtr(), n, N, output.getPtr(), false, silent);
//PutRNGstate();
}
void SEXP_2_NimArr<1>(SEXP Sn, NimArr<1, int> &ans) {
if(!(isNumeric(Sn) || isLogical(Sn))) PRINTF("Error: SEXP_2_NimArr<1> called for SEXP that is not a numeric or logical!\n");
int nn = LENGTH(Sn);
if(ans.size() != 0) PRINTF("Error: trying to reset a NimArr that was already sized\n");
ans.setSize(nn);
if(isReal(Sn)) {
std::copy(REAL(Sn), REAL(Sn) + nn, ans.getPtr());
} else {
if(isInteger(Sn) || isLogical(Sn)) {
int *iSn = isInteger(Sn) ? INTEGER(Sn) : LOGICAL(Sn);
for(int i = 0; i < nn; ++i) {
ans(i) = static_cast<double>(iSn[i]);
}
} else {
PRINTF("Error: We could not handle the R input type to SEXP_2_NimArr<1>\n");
}
}
}
// 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;
}
