static SEXP AddParens(SEXP expr)
{
SEXP e;
if (TYPEOF(expr) == LANGSXP) {
e = CDR(expr);
while(e != R_NilValue) {
SETCAR(e, AddParens(CAR(e)));
e = CDR(e);
}
}
if (isPlusForm(expr)) {
if (isPlusForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
else if (isMinusForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
else if (isTimesForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
}
else if (isDivideForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
}
else if (isPowerForm(expr)) {
if (isPowerForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
return expr;
}
double genoud_optim(SEXP fn_optim, SEXP rho, double *X, long parameters)
{
SEXP ans, R_fcall, x;
double fit;
long i;
PROTECT(x = allocVector(REALSXP, parameters));
for (i=0; i<parameters; i++)
{
REAL(x)[i] = X[i];
}
PROTECT(R_fcall = lang2(fn_optim, R_NilValue));
SETCADR(R_fcall, x);
ans = eval(R_fcall, rho);
fit = REAL(ans)[0];
for(i=0; i<parameters; i++)
{
X[i] = REAL(ans)[i+1];
}
UNPROTECT(2);
return(fit);
} // end of genoud_optim()
double perfunc(SEXP myldens, ENVELOPE *env, double x, SEXP rho)
/* to evaluate log density and increment count of evaluations */
/* myldens : R function to evaluate log density */
/* *env : envelope attributes */
/* x : point at which to evaluate log density */
/* rho : R environment in which the logdensity is evaluated */
{
double y;
SEXP R_fcall, arg;
/* evaluate logdensity function */
PROTECT(R_fcall = lang2(myldens, R_NilValue));
PROTECT(arg = NEW_NUMERIC(1));
NUMERIC_POINTER(arg)[0] = x;
SETCADR(R_fcall, arg);
y = REAL(eval(R_fcall, rho))[0];
UNPROTECT(2);
/* increment count of function evaluations */
(*(env->neval))++;
return y;
}
bool Engine::judgeConstraint()
{
SEXP x4R, val;
int res;
// Allocate vector for R which is size of the vector in the R context.
PROTECT(x4R = allocVector(REALSXP, x_.size()));
if (!rEnv_->xNames)
setAttrib(x4R, R_NamesSymbol, rEnv_->xNames);
for (unsigned int i = 0; i < x_.size(); i++)
{
if (!R_FINITE(x_[i]))
{
Rprintf("x[%i] is NAN: %.10g\n", i, x_[i]);
REAL(x4R)[i] = 0;
}
else
{
REAL(x4R)[i] = x_[i];
}
}
SETCADR(rEnv_->R_jc, x4R);
val = eval(rEnv_->R_jc, rEnv_->R_env);
res = LOGICAL(val)[0];
UNPROTECT(1);
return res;
}
static void rextmat_tmatmul(double* out,
const double* v,
const void* matrix) {
rext_matrix *e = (rext_matrix*)matrix;
SEXP rho, rV, res, tfcall;
unsigned n, m;
PROTECT_INDEX ipx;
/* Grab the matrix dimensions */
n = e->n;
m = e->m;
/* Grab the environment we're going to evaluate function in */
rho = R_WeakRefValue(e->rho);
/* Grab the function */
tfcall = R_WeakRefValue(e->tfcall);
/* Allocate the memory to call R code and prepare the input*/
PROTECT(rV = allocVector(REALSXP, n));
Memcpy(REAL(rV), v, n);
/* Call the actual function */
SETCADR(tfcall, rV);
PROTECT_WITH_INDEX(res = eval(tfcall, rho), &ipx);
REPROTECT(res = coerceVector(res, REALSXP), ipx);
/* Prepare the output */
Memcpy(out, REAL(res), m);
UNPROTECT(2);
}
static double fcn1(double x, struct callinfo *info)
{
SEXP s, sx;
PROTECT(sx = ScalarReal(x));
SETCADR(info->R_fcall, sx);
s = eval(info->R_fcall, info->R_env);
UNPROTECT(1);
switch(TYPEOF(s)) {
case INTSXP:
if (length(s) != 1) goto badvalue;
if (INTEGER(s)[0] == NA_INTEGER) {
warning(_("NA replaced by maximum positive value"));
return DBL_MAX;
}
else return INTEGER(s)[0];
break;
case REALSXP:
if (length(s) != 1) goto badvalue;
if (!R_FINITE(REAL(s)[0])) {
warning(_("NA/Inf replaced by maximum positive value"));
return DBL_MAX;
}
else return REAL(s)[0];
break;
default:
goto badvalue;
}
badvalue:
error(_("invalid function value in 'optimize'"));
return 0;/* for -Wall */
}
static void omxCallRFitFunction(omxFitFunction *oo, int want, FitContext *) {
if (want & (FF_COMPUTE_PREOPTIMIZE)) return;
omxRFitFunction* rFitFunction = (omxRFitFunction*)oo->argStruct;
SEXP theCall, theReturn;
ScopedProtect p2(theCall, Rf_allocVector(LANGSXP, 3));
SETCAR(theCall, rFitFunction->fitfun);
SETCADR(theCall, rFitFunction->model);
SETCADDR(theCall, rFitFunction->state);
{
ScopedProtect p1(theReturn, Rf_eval(theCall, R_GlobalEnv));
if (LENGTH(theReturn) < 1) {
// seems impossible, but report it if it happens
omxRaiseErrorf("FitFunction returned nothing");
} else if (LENGTH(theReturn) == 1) {
oo->matrix->data[0] = Rf_asReal(theReturn);
} else if (LENGTH(theReturn) == 2) {
oo->matrix->data[0] = Rf_asReal(VECTOR_ELT(theReturn, 0));
R_Reprotect(rFitFunction->state = VECTOR_ELT(theReturn, 1), rFitFunction->stateIndex);
} else if (LENGTH(theReturn) > 2) {
omxRaiseErrorf("FitFunction returned more than 2 arguments");
}
}
}
static SEXP CreateHess(SEXP names)
{
SEXP p, q, data, dim, dimnames;
int i, n;
n = length(names);
PROTECT(dimnames = lang4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
SETCAR(dimnames, install("list"));
p = install("c");
PROTECT(q = allocList(n));
SETCADDR(dimnames, LCONS(p, q));
UNPROTECT(1);
for(i = 0 ; i < n ; i++) {
SETCAR(q, ScalarString(STRING_ELT(names, i)));
q = CDR(q);
}
SETCADDDR(dimnames, duplicate(CADDR(dimnames)));
PROTECT(dim = lang4(R_NilValue, R_NilValue, R_NilValue,R_NilValue));
SETCAR(dim, install("c"));
SETCADR(dim, lang2(install("length"), install(".value")));
SETCADDR(dim, ScalarInteger(length(names)));
SETCADDDR(dim, ScalarInteger(length(names)));
PROTECT(data = ScalarReal(0.));
PROTECT(p = lang4(install("array"), data, dim, dimnames));
p = lang3(install("<-"), install(".hessian"), p);
UNPROTECT(4);
return p;
}
static void genptry(int n, double *p, double *ptry, double scale, void *ex)
{
SEXP s, x;
int i;
OptStruct OS = (OptStruct) ex;
PROTECT_INDEX ipx;
if (!isNull(OS->R_gcall)) {
/* user defined generation of candidate point */
PROTECT(x = allocVector(REALSXP, n));
for (i = 0; i < n; i++) {
if (!R_FINITE(p[i]))
error(_("non-finite value supplied by 'optim'"));
REAL(x)[i] = p[i] * (OS->parscale[i]);
}
SETCADR(OS->R_gcall, x);
PROTECT_WITH_INDEX(s = eval(OS->R_gcall, OS->R_env), &ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
if(LENGTH(s) != n)
error(_("candidate point in 'optim' evaluated to length %d not %d"),
LENGTH(s), n);
for (i = 0; i < n; i++)
ptry[i] = REAL(s)[i] / (OS->parscale[i]);
UNPROTECT(2);
}
else { /* default Gaussian Markov kernel */
for (i = 0; i < n; i++)
ptry[i] = p[i] + scale * norm_rand(); /* new candidate point */
}
}
/* zeroin(f, xmin, xmax, tol, maxiter) */
SEXP do_zeroin(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double xmin, xmax, tol;
int iter;
SEXP v, res;
struct callinfo info;
checkArity(op, args);
PrintDefaults(rho);
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
errorcall(call, _("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin))
errorcall(call, _("invalid 'xmin' value"));
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax))
errorcall(call, _("invalid 'xmax' value"));
if (xmin >= xmax)
errorcall(call, _("'xmin' not less than 'xmax'"));
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0)
errorcall(call, _("invalid 'tol' value"));
args = CDR(args);
/* maxiter */
iter = asInteger(CAR(args));
if (iter <= 0)
errorcall(call, _("'maxiter' must be positive"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue)); /* the info used in fcn2() */
SETCADR(info.R_fcall, allocVector(REALSXP, 1));
PROTECT(res = allocVector(REALSXP, 3));
REAL(res)[0] =
R_zeroin(xmin, xmax, (double (*)(double, void*)) fcn2,
(void *) &info, &tol, &iter);
REAL(res)[1] = (double)iter;
REAL(res)[2] = tol;
UNPROTECT(2);
return res;
}
static SEXP DerivAssign(SEXP name, SEXP expr)
{
SEXP ans, newname;
PROTECT(ans = lang3(install("<-"), R_NilValue, expr));
PROTECT(newname = ScalarString(name));
SETCADR(ans, lang4(R_BracketSymbol, install(".grad"), R_MissingArg, newname));
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_commentgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
setAttrib(CAR(args), R_CommentSymbol, CADR(args));
SET_NAMED(CAR(args), 0);
return CAR(args);
}
void omxGlobal::reportProgressStr(const char *msg)
{
ProtectedSEXP theCall(Rf_allocVector(LANGSXP, 3));
SETCAR(theCall, Rf_install("imxReportProgress"));
ProtectedSEXP Rmsg(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(Rmsg, 0, Rf_mkChar(msg));
SETCADR(theCall, Rmsg);
SETCADDR(theCall, Rf_ScalarInteger(previousReportLength));
Rf_eval(theCall, R_GlobalEnv);
}
/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *ctxt;
SEXP code, oldcode, tmp, argList;
int addit = 0;
static SEXP do_onexit_formals = NULL;
if (do_onexit_formals == NULL)
do_onexit_formals = allocFormalsList2(install("expr"), install("add"));
PROTECT(argList = matchArgs(do_onexit_formals, args, call));
if (CAR(argList) == R_MissingArg) code = R_NilValue;
else code = CAR(argList);
if (CADR(argList) != R_MissingArg) {
addit = asLogical(eval(CADR(args), rho));
if (addit == NA_INTEGER)
errorcall(call, _("invalid '%s' argument"), "add");
}
ctxt = R_GlobalContext;
/* Search for the context to which the on.exit action is to be
attached. Lexical scoping is implemented by searching for the
first closure call context with an environment matching the
expression evaluation environment. */
while (ctxt != R_ToplevelContext &&
!((ctxt->callflag & CTXT_FUNCTION) && ctxt->cloenv == rho) )
ctxt = ctxt->nextcontext;
if (ctxt->callflag & CTXT_FUNCTION)
{
if (addit && (oldcode = ctxt->conexit) != R_NilValue ) {
if ( CAR(oldcode) != R_BraceSymbol )
{
PROTECT(tmp = allocList(3));
SETCAR(tmp, R_BraceSymbol);
SETCADR(tmp, oldcode);
SETCADDR(tmp, code);
SET_TYPEOF(tmp, LANGSXP);
ctxt->conexit = tmp;
UNPROTECT(1);
}
else
{
PROTECT(tmp = allocList(1));
SETCAR(tmp, code);
ctxt->conexit = listAppend(duplicate(oldcode),tmp);
UNPROTECT(1);
}
}
else
ctxt->conexit = code;
}
UNPROTECT(1);
return R_NilValue;
}
/* oldClass<-(), primitive */
SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
if(IS_S4_OBJECT(CAR(args)))
UNSET_S4_OBJECT(CAR(args));
setAttrib(CAR(args), R_ClassSymbol, CADR(args));
SET_NAMED(CAR(args), 0);
return CAR(args);
}
/* fmin(f, xmin, xmax tol) */
SEXP do_fmin(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double xmin, xmax, tol;
SEXP v, res;
struct callinfo info;
checkArity(op, args);
PrintDefaults(rho);
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
errorcall(call, _("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin))
errorcall(call, _("invalid 'xmin' value"));
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax))
errorcall(call, _("invalid 'xmax' value"));
if (xmin >= xmax)
errorcall(call, _("'xmin' not less than 'xmax'"));
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0)
errorcall(call, _("invalid 'tol' value"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue));
PROTECT(res = allocVector(REALSXP, 1));
SETCADR(info.R_fcall, allocVector(REALSXP, 1));
REAL(res)[0] = Brent_fmin(xmin, xmax,
(double (*)(double, void*)) fcn1, &info, tol);
UNPROTECT(2);
return res;
}
static SEXP
summary_func_user_Rfunc (Sampler *ss, int currentPeriod, SEXP currentStreams,
SEXP currentLogWeights)
{
ArgsList2 *al = ss->summaryArgsList;
INTEGER(ss->SEXPCurrentPeriod)[0] = currentPeriod + 1;
SET_VECTOR_ELT(al->argsList, al->posCurrentPeriod, ss->SEXPCurrentPeriod);
SET_VECTOR_ELT(al->argsList, al->posCurrentStreams, currentStreams);
SET_VECTOR_ELT(al->argsList, al->posCurrentLogWeights, currentLogWeights);
SETCADR(ss->doCallFuncCall, ss->summaryFunc);
SETCADDR(ss->doCallFuncCall, al->argsList);
SETCADDDR(ss->doCallFuncCall, ss->dotsList);
return eval(ss->doCallFuncCall, ss->doCallFuncEnv);
}
static double R_fun(double x, void *data){
mh_str *da = data ;
SEXP R_x, s ;
PROTECT_INDEX ipx;
PROTECT(R_x = allocVector(REALSXP, 1));
REAL(R_x)[0] = x ;
SETCADR(da->R_fcall, R_x); /* assign the argument */
/* evaluate function calls */
PROTECT_WITH_INDEX(s = eval(da->R_fcall, da->R_env), &ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
if (LENGTH(s) != 1)
error(("objective function evaluates to length %d not 1"), LENGTH(s));
if (!R_FINITE(REAL(s)[0]) || R_IsNaN(REAL(s)[0]) || R_IsNA(REAL(s)[0]))
error("objective funtion evaluates to Inf, NaN or NA");
UNPROTECT(2);
return REAL(s)[0];
}
SEXP lapply2(SEXP list, SEXP fn, SEXP rho)
{
int i, n = length(list);
SEXP R_fcall, ans;
if(!isNewList(list)) error("`list' must be a list");
if(!isFunction(fn)) error("`fn' must be a function");
if(!isEnvironment(rho)) error("`rho' should be an environment");
PROTECT(R_fcall = lang2(fn, R_NilValue));
PROTECT(ans = allocVector(VECSXP, n));
for(i = 0; i < n; i++) {
SETCADR(R_fcall, VECTOR_ELT(list, i));
SET_VECTOR_ELT(ans, i, eval(R_fcall, rho));
}
setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
UNPROTECT(2);
return(ans);
}
static SEXP
propagate_func_user_Rfunc (Sampler *ss, int currentPeriod, int nStreamsToGenerate,
SEXP lag1Streams, SEXP lag1LogWeights)
{
ArgsList1 *al = ss->propagateArgsList;
INTEGER(ss->SEXPCurrentPeriod)[0] = currentPeriod + 1;
INTEGER(ss->SEXPNStreamsToGenerate)[0] = nStreamsToGenerate;
SET_VECTOR_ELT(al->argsList, al->posCurrentPeriod, ss->SEXPCurrentPeriod);
SET_VECTOR_ELT(al->argsList, al->posNStreamsToGenerate, ss->SEXPNStreamsToGenerate);
SET_VECTOR_ELT(al->argsList, al->posLag1Streams, lag1Streams);
SET_VECTOR_ELT(al->argsList, al->posLag1LogWeights, lag1LogWeights);
SETCADR(ss->doCallFuncCall, ss->propagateFunc);
SETCADDR(ss->doCallFuncCall, al->argsList);
SETCADDDR(ss->doCallFuncCall, ss->dotsList);
return eval(ss->doCallFuncCall, ss->doCallFuncEnv);
}
static SEXP
MHUpdate_func_user_Rfunc (Sampler *ss, int currentPeriod, int nMHSteps,
SEXP currentStreams, SEXP lag1Streams,
SEXP lag1LogWeights)
{
ArgsList3 *al = ss->MHUpdateArgsList;
INTEGER(ss->SEXPCurrentPeriod)[0] = currentPeriod + 1;
INTEGER(ss->SEXPNMHSteps)[0] = nMHSteps;
SET_VECTOR_ELT(al->argsList, al->posCurrentPeriod, ss->SEXPCurrentPeriod);
SET_VECTOR_ELT(al->argsList, al->posNMHSteps, ss->SEXPNMHSteps);
SET_VECTOR_ELT(al->argsList, al->posCurrentStreams, currentStreams);
SET_VECTOR_ELT(al->argsList, al->posLag1Streams, lag1Streams);
SET_VECTOR_ELT(al->argsList, al->posLag1LogWeights, lag1LogWeights);
SETCADR(ss->doCallFuncCall, ss->MHUpdateFunc);
SETCADDR(ss->doCallFuncCall, al->argsList);
SETCADDDR(ss->doCallFuncCall, ss->dotsList);
return eval(ss->doCallFuncCall, ss->doCallFuncEnv);
}
/* This function is called by geodesiclm.f90 after each iteration, the function is evaluated at 'par' and the result
is stored in 'fvec'. */
void fcn_call(int *m, int *n, double *par, double *v, double *a, double *fvec, double *fjac,
double *acc, double *lam, double *dtd, double *fvec_new, int *accepted, int *info)
{
int i;
SEXP sexp_fjac;
/* Rprintf("fcn-lmdif calling...\n"); */
// Update value of 'par' stored in OS
SETCADR(OS->jcall, OS->par);
PROTECT(sexp_fjac = eval(OS->jcall, OS->env));
for (i = 0; i < *m; i++)
fjac[i] = NUMERIC_POINTER(sexp_jac)[i];
UNPROTECT(1);
// Set iflag if niter reaches the maximum
if (OS->niter == OS->maxiter)
*info = -1;
}
void redux_redis_subscribe_loop(redisContext* context, int pattern,
SEXP callback, SEXP envir) {
if (!isFunction(callback)) {
error("'callback' must be a function");
}
if (!isEnvironment(envir)) {
error("'envir' must be an environment");
}
SEXP call = PROTECT(lang2(callback, R_NilValue));
redisReply *reply = NULL;
int keep_going = 1;
// Nasty:
SEXP nms = PROTECT(allocVector(STRSXP, pattern ? 4 : 3));
int i = 0;
SET_STRING_ELT(nms, i++, mkChar("type"));
if (pattern) {
SET_STRING_ELT(nms, i++, mkChar("pattern"));
}
SET_STRING_ELT(nms, i++, mkChar("channel"));
SET_STRING_ELT(nms, i++, mkChar("value"));
// And we're off. Adding a timeout here seems sensible to me as
// that would allow for _some_ sort of interrupt checking, but as it
// is, this seems extremely difficult to do without risking killing
// the client.
while (keep_going) {
R_CheckUserInterrupt();
redisGetReply(context, (void*)&reply);
SEXP x = PROTECT(redis_reply_to_sexp(reply, REPLY_ERROR_OK));
setAttrib(x, R_NamesSymbol, nms);
SETCADR(call, x);
freeReplyObject(reply);
SEXP val = PROTECT(eval(call, envir));
if (TYPEOF(val) == LGLSXP && LENGTH(val) == 1 && INTEGER(val)[0] == 1) {
keep_going = 0;
}
UNPROTECT(2); // x, val
}
UNPROTECT(2); // nms, call
}
static Rboolean
resampCriterion_func_user_Rfunc (Sampler *ss, int currentPeriod, SEXP currentStreams,
SEXP currentLogWeights)
{
ArgsList2 *al = ss->resampCriterionArgsList;
SEXP SEXPTmp;
Rboolean res;
INTEGER(ss->SEXPCurrentPeriod)[0] = currentPeriod + 1;
SET_VECTOR_ELT(al->argsList, al->posCurrentPeriod, ss->SEXPCurrentPeriod);
SET_VECTOR_ELT(al->argsList, al->posCurrentStreams, currentStreams);
SET_VECTOR_ELT(al->argsList, al->posCurrentLogWeights, currentLogWeights);
SETCADR(ss->doCallFuncCall, ss->resampCriterionFunc);
SETCADDR(ss->doCallFuncCall, al->argsList);
SETCADDDR(ss->doCallFuncCall, ss->dotsList);
PROTECT(SEXPTmp = eval(ss->doCallFuncCall, ss->doCallFuncEnv));
res = LOGICAL(SEXPTmp)[0];
UNPROTECT(1);
return res;
}
SEXP loop_apply(SEXP n, SEXP f, SEXP rho) {
if(!isFunction(f)) error("'f' must be a function");
if(!isEnvironment(rho)) error("'rho' should be an environment");
int n1 = INTEGER(n)[0];
SEXP results, R_fcall;
PROTECT(results = allocVector(VECSXP, n1));
PROTECT(R_fcall = lang2(f, R_NilValue));
SEXP ii;
for(int i = 0; i < n1; i++) {
PROTECT(ii = ScalarInteger(i + 1));
SETCADR(R_fcall, ii);
SET_VECTOR_ELT(results, i, eval(R_fcall, rho));
UNPROTECT(1);
}
UNPROTECT(2);
return results;
}
void diagParallel(int verbose, const char* msg, ...)
{
if (!verbose && !Global->parallelDiag) return;
const int maxLen = 240;
char buf1[maxLen];
va_list ap;
va_start(ap, msg);
vsnprintf(buf1, maxLen, msg, ap);
va_end(ap);
if (verbose) {
mxLog("%s", buf1);
} else if (Global->parallelDiag) {
ProtectedSEXP theCall(Rf_allocVector(LANGSXP, 2));
SETCAR(theCall, Rf_install("message"));
ProtectedSEXP Rmsg(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(Rmsg, 0, Rf_mkChar(buf1));
SETCADR(theCall, Rmsg);
Rf_eval(theCall, R_GlobalEnv);
}
}
static double fminfn(int n, double *p, void *ex)
{
SEXP s, x;
int i;
double val;
OptStruct OS = (OptStruct) ex;
PROTECT_INDEX ipx;
PROTECT(x = allocVector(REALSXP, n));
if(!isNull(OS->names)) setAttrib(x, R_NamesSymbol, OS->names);
for (i = 0; i < n; i++) {
if (!R_FINITE(p[i])) error(_("non-finite value supplied by optim"));
REAL(x)[i] = p[i] * (OS->parscale[i]);
}
SETCADR(OS->R_fcall, x);
PROTECT_WITH_INDEX(s = eval(OS->R_fcall, OS->R_env), &ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
if (LENGTH(s) != 1)
error(_("objective function in optim evaluates to length %d not 1"),
LENGTH(s));
val = REAL(s)[0]/(OS->fnscale);
UNPROTECT(2);
return val;
}
double Engine::fn(const dVec& x)
{
SEXP x4R, val;
double res = 0;
if (isVerbose())
{
Rprintf(".");
}
// Allocate vector for R which is size of the vector in the R context.
PROTECT(x4R = allocVector(REALSXP, x.size()));
if (!rEnv_->xNames)
setAttrib(x4R, R_NamesSymbol, rEnv_->xNames);
for (unsigned int i = 0; i < x.size(); i++)
{
if (!R_FINITE(x[i]))
{
if (isVerbose())
{
Rprintf("x[%i] is NAN: %.10g\n", i, x[i]);
}
REAL(x4R)[i] = 0.;
}
else
{
REAL(x4R)[i] = x[i];
}
}
SETCADR(rEnv_->R_fn, x4R);
val = eval(rEnv_->R_fn, rEnv_->R_env);
res = REAL(val)[0];
UNPROTECT(1);
return res;
}
static SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop)
{
SEXP attr, result, sr, sc, dim;
int nr, nc, nrs, ncs;
R_xlen_t i, j, ii, jj, ij, iijj;
nr = nrows(x);
nc = ncols(x);
/* Note that "s" is protected on entry. */
/* The following ensures that pointers remain protected. */
dim = getAttrib(x, R_DimSymbol);
sr = SETCAR(s, int_arraySubscript(0, CAR(s), dim, x, call));
sc = SETCADR(s, int_arraySubscript(1, CADR(s), dim, x, call));
nrs = LENGTH(sr);
ncs = LENGTH(sc);
/* Check this does not overflow: currently only possible on 32-bit */
if ((double)nrs * (double)ncs > R_XLEN_T_MAX)
error(_("dimensions would exceed maximum size of array"));
PROTECT(sr);
PROTECT(sc);
result = allocVector(TYPEOF(x), (R_xlen_t) nrs * (R_xlen_t) ncs);
PROTECT(result);
for (i = 0; i < nrs; i++) {
ii = INTEGER(sr)[i];
if (ii != NA_INTEGER) {
if (ii < 1 || ii > nr)
errorcall(call, R_MSG_subs_o_b);
ii--;
}
for (j = 0; j < ncs; j++) {
jj = INTEGER(sc)[j];
if (jj != NA_INTEGER) {
if (jj < 1 || jj > nc)
errorcall(call, R_MSG_subs_o_b);
jj--;
}
ij = i + j * nrs;
if (ii == NA_INTEGER || jj == NA_INTEGER) {
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(result)[ij] = NA_INTEGER;
break;
case REALSXP:
REAL(result)[ij] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(result)[ij].r = NA_REAL;
COMPLEX(result)[ij].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(result, ij, NA_STRING);
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, R_NilValue);
break;
case RAWSXP:
RAW(result)[ij] = (Rbyte) 0;
break;
default:
errorcall(call, _("matrix subscripting not handled for this type"));
break;
}
}
else {
iijj = ii + jj * nr;
switch (TYPEOF(x)) {
case LGLSXP:
LOGICAL(result)[ij] = LOGICAL(x)[iijj];
break;
case INTSXP:
INTEGER(result)[ij] = INTEGER(x)[iijj];
break;
case REALSXP:
REAL(result)[ij] = REAL(x)[iijj];
break;
case CPLXSXP:
COMPLEX(result)[ij] = COMPLEX(x)[iijj];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, VECTOR_ELT_FIX_NAMED(x, iijj));
break;
case RAWSXP:
RAW(result)[ij] = RAW(x)[iijj];
break;
default:
errorcall(call, _("matrix subscripting not handled for this type"));
break;
}
}
}
}
if(nrs >= 0 && ncs >= 0) {
PROTECT(attr = allocVector(INTSXP, 2));
INTEGER(attr)[0] = nrs;
INTEGER(attr)[1] = ncs;
setAttrib(result, R_DimSymbol, attr);
UNPROTECT(1);
}
/* The matrix elements have been transferred. Now we need to */
/* transfer the attributes. Most importantly, we need to subset */
/* the dimnames of the returned value. */
if (nrs >= 0 && ncs >= 0) {
SEXP dimnames, dimnamesnames, newdimnames;
dimnames = getAttrib(x, R_DimNamesSymbol);
PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
if (!isNull(dimnames)) {
PROTECT(newdimnames = allocVector(VECSXP, 2));
if (TYPEOF(dimnames) == VECSXP) {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(VECTOR_ELT(dimnames, 0),
allocVector(STRSXP, nrs), sr, call));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(VECTOR_ELT(dimnames, 1),
allocVector(STRSXP, ncs), sc, call));
}
else {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(CAR(dimnames),
allocVector(STRSXP, nrs), sr, call));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(CADR(dimnames),
allocVector(STRSXP, ncs), sc, call));
}
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, newdimnames);
UNPROTECT(1); /* newdimnames */
}
UNPROTECT(1); /* dimnamesnames */
}
/* Probably should not do this:
copyMostAttrib(x, result); */
if (drop)
DropDims(result);
UNPROTECT(3);
return result;
}
SEXP predoslda(SEXP s_test, SEXP s_learn, SEXP s_grouping, SEXP s_wf, SEXP s_bw, SEXP s_k, SEXP s_method, SEXP s_env)
{
const R_len_t p = ncols(s_test); // dimensionality
R_len_t N_learn = nrows(s_learn); // # training observations
const R_len_t N_test = nrows(s_test); // # test observations
const R_len_t K = nlevels(s_grouping); // # classes
double *test = REAL(s_test); // pointer to test data set
double *learn = REAL(s_learn); // pointer to training data set
int *g = INTEGER(s_grouping); // pointer to class labels
int *k = INTEGER(s_k); // pointer to number of nearest neighbors
const int method = INTEGER(s_method)[0]; // method for scaling the covariance matrices
//Rprintf("%u\n", method);
SEXP s_posterior; // initialize posteriors
PROTECT(s_posterior = allocMatrix(REALSXP, N_test, K));
double *posterior = REAL(s_posterior);
SEXP s_dist; // initialize distances to test observation
PROTECT(s_dist = allocVector(REALSXP, N_learn));
double *dist = REAL(s_dist);
SEXP s_weights; // initialize weight vector
PROTECT(s_weights = allocVector(REALSXP, N_learn));
double *weights = REAL(s_weights);
double sum_weights; // sum of weights
double class_weights[K]; // class wise sum of weights
double norm_weights = 0; // normalization factor for unbiased version of covariance matrix
double center[K][p]; // class means
double covmatrix[p * p]; // pooled covariance matrix
double z[p * K]; // difference between trial point and class center
const char uplo = 'L', side = 'L';
int info = 0;
double onedouble = 1.0, zerodouble = 0.0;
double C[p * K];
double post[K];
int nas = 0;
int i, j, l, m, n; // indices
// select weight function
typedef void (*wf_ptr_t) (double*, double*, int*, double*, int*);// *weights, *dist, *N, *bw, *k
wf_ptr_t wf = NULL;
if (isInteger(s_wf)) {
const int wf_nr = INTEGER(s_wf)[0];
wf_ptr_t wfs[] = {biweight1, cauchy1, cosine1, epanechnikov1, exponential1, gaussian1,
optcosine1, rectangular1, triangular1, biweight2, cauchy2, cosine2, epanechnikov2,
exponential2, gaussian2, optcosine2, rectangular2, triangular2, biweight3, cauchy3,
cosine3, epanechnikov3, exponential3, gaussian3, optcosine3, rectangular3,
triangular3, cauchy4, exponential4, gaussian4};
wf = wfs[wf_nr - 1];
}
// loop over all test observations
for(n = 0; n < N_test; n++) {
// 0. check for NAs in test
nas = 0;
for (j = 0; j < p; j++) {
nas += ISNA(test[n + N_test * j]);
}
if (nas > 0) { // NAs in n-th test observation
warning("NAs in test observation %u", n+1);
// set posterior to NA
for (m = 0; m < K; m++) {
posterior[n + N_test * m] = NA_REAL;
}
} else {
// 1. calculate distances to n-th test observation
for (i = 0; i < N_learn; i++) {
dist[i] = 0;
for (j = 0; j < p; j++) {
dist[i] += pow(learn[i + N_learn * j] - test[n + N_test * j], 2);
}
dist[i] = sqrt(dist[i]);
weights[i] = 0;
//Rprintf("dist %f\n", dist[i]);
}
// 2. calculate observation weights
if (isInteger(s_wf)) {
// case 1: wf is integer
// calculate weights by reading number and calling corresponding C function
wf (weights, dist, &N_learn, REAL(s_bw), k);
} else if (isFunction(s_wf)) {
// case 2: wf is R function
// calculate weights by calling R function
SEXP R_fcall;
PROTECT(R_fcall = lang2(s_wf, R_NilValue));
SETCADR(R_fcall, s_dist);
weights = REAL(eval(R_fcall, s_env));
UNPROTECT(1); // R_fcall
}
/*for(i = 0; i < N_learn; i++) {
Rprintf("weights %f\n", weights[i]);
}*/
// 3. initialization
sum_weights = 0;
for (m = 0; m < K; m++) {
class_weights[m] = 0;
for (j = 0; j < p; j++) {
center[m][j] = 0;
for (l = 0; l <= j; l++) {
covmatrix[j + p * l] = 0;
}
}
}
// 4. calculate sum of weights, class wise sum of weights and unnormalized class means
for (i = 0; i < N_learn; i++) {
sum_weights += weights[i];
for (m = 0; m < K; m++) {
if (g[i] == m + 1) {
class_weights[m] += weights[i];
for (j = 0; j < p; j++) {
center[m][j] += learn[i + N_learn * j] * weights[i];
}
}
}
}
//Rprintf("sum_weights %f\n", sum_weights);
if (sum_weights == 0) { // all observation weights are zero
warning("all observation weights are zero");
// set posterior to NA
for (m = 0; m < K; m++) {
posterior[n + N_test * m] = NA_REAL;
}
} else {
// 5. calculate covariance matrix, only lower triangle
if (method == 1) { // unbiased estimate
norm_weights = 0;
for (m = 0; m < K; m++) {
//Rprintf("class_weights %f \n", class_weights[m]);
if (class_weights[m] > 0) {
for (i = 0; i < N_learn; i++) {
if (g[i] == m + 1) {
norm_weights += class_weights[m]/sum_weights * pow(weights[i]/class_weights[m], 2);
}
}
}
}
//Rprintf("norm_weights %f\n", norm_weights);
if (norm_weights == 1) { // it makes no sense to calculate the covariance matrix
warning("iteration %u: NaNs in covariance matrix", n+1);
} else { // calculate covariance matrix
for (m = 0; m < K; m++) {
if (class_weights[m] > 0) { // only for classes with positive sum of weights
for (i = 0; i < N_learn; i++) {
if (g[i] == m + 1) {
for (j = 0; j < p; j++) {
for (l = 0; l <= j; l++) {
covmatrix[j + p * l] += weights[i]/sum_weights *
(learn[i + N_learn * j] - center[m][j]/class_weights[m]) *
(learn[i + N_learn * l] - center[m][l]/class_weights[m])/
(1 - norm_weights);
}
}
}
}
}
}
}
} else { // ML estimate
for (m = 0; m < K; m++) {
if (class_weights[m] > 0) { // only for classes with positive sum of weights
for (i = 0; i < N_learn; i++) {
if (g[i] == m + 1) {
for (j = 0; j < p; j++) {
for (l = 0; l <= j; l++) {
covmatrix[j + p * l] += weights[i]/sum_weights *
(learn[i + N_learn * j] - center[m][j]/class_weights[m]) *
(learn[i + N_learn * l] - center[m][l]/class_weights[m]);
}
}
}
}
}
}
}
/*for (j = 0; j < p; j++) {
for (l = 0; l <= j; l++) {
Rprintf("covmatrix %f\n", covmatrix[j + p * l]);
}
}*/
if (norm_weights == 1) { // then nans in covmatrix, sum_weights = 0?
for (m = 0; m < K; m++) {
posterior[n + N_test * m] = NA_REAL;
}
} else {
// 6. calculate inverse of covmatrix
F77_CALL(dpotrf)(&uplo, &p, covmatrix, &p, &info);
//Rprintf("info dpotrf %u\n", info);
if (info != 0) { // error in Choleski factorization
if (info < 0) {
warning("iteration %u: argument %u had an illegal value\n", n+1, abs(info));
} else {
warning("iteration %u: the leading minor of order %u is not positive definite and the Cholesky factorization could not be completed\n", n+1, info);
}
// set posterior to NA
for (m = 0; m < K; m++) {
posterior[n + N_test * m] = NA_REAL;
}
} else { // proceed with calculation of inverse covmatrix
F77_CALL(dpotri)(&uplo, &p, covmatrix, &p, &info);
//Rprintf("info dpotri %u\n", info);
if (info != 0) { // error in calculation of inverse covmatrix
if (info < 0) {
warning("iteration %u: argument %u had an illegal value\n", n+1, abs(info));
} else {
warning("iteration %u: element (%u, %u) of factor L is zero\n", n+1, info, info);
}
// set posterior to NA
for (m = 0; m < K; m++) {
posterior[n + N_test * m] = NA_REAL;
}
} else { // proceed
// 7. calculate difference between n-th test observation and all class centers
for (m = 0; m < K; m++) {
if (class_weights[m] > 0) { // only for classes with positive sum of weights
for (j = 0; j < p; j++) {
z[j + p * m] = test[n + N_test * j] - center[m][j]/class_weights[m];
}
} else {
for (j = 0; j < p; j++) {
z[j + p * m] = 0;
}
}
}
// 8. calcualte C = covmatrix * z
F77_CALL(dsymm)(&side, &uplo, &p, &K, &onedouble, covmatrix, &p, z, &p, &zerodouble, C, &p);
// 9. calculate t(z) * C (mahalanobis distance) and unnormalized posterior probabilities
for (m = 0; m < K; m++) {
if (class_weights[m] > 0) {
post[m] = 0;
for (j = 0; j < p; j++) {
post[m] += C[j + p * m] * z[j + p * m];
}
posterior[n + N_test * m] = log(class_weights[m]/sum_weights) - 0.5 * post[m];
} else {
posterior[n + N_test * m] = R_NegInf;
}
//Rprintf("posterior %f\n", posterior[n + N_test * m]);
}
}
}
}
}
}
}
// end loop over test observations
// 10. set dimnames of s_posterior
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(getAttrib(s_test, R_DimNamesSymbol), 0));
SET_VECTOR_ELT(dimnames, 1, getAttrib(s_grouping, R_LevelsSymbol));
setAttrib(s_posterior, R_DimNamesSymbol, dimnames);
UNPROTECT(4); // dimnames, s_dist, s_weights, s_posterior
return(s_posterior);
}