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 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;
}
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");
}
}
}
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;
}
SEXP jr_func(void* p)
{
ParseStatus status;
SEXP s, t, ext;
s = t = PROTECT(R_ParseVector(
Rf_mkString("function(...) {.External(\".RCall\", NULL, ...)}"),
-1, &status, R_NilValue));
ext = PROTECT(R_MakeExternalPtr(p, R_NilValue, R_NilValue));
SETCADDR(CADR(CADDR(VECTOR_ELT(t ,0))), ext);
int errorOccurred = 0;
SEXP ret;
ret = PROTECT(R_tryEval(VECTOR_ELT(s,0), R_GlobalEnv, &errorOccurred));
UNPROTECT(3);
return ret;
}
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 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);
}
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 grid_int_CB(SEXP F, // vector array of response values dim 'dim'
SEXP nLev, // vector of levels numbers
SEXP nStar, // c(1, cumprod(nLev))
SEXP xLev, // list of levels
SEXP Xout, // matrix of output values nout * d
SEXP interpCB , // Cardinal Basis
SEXP rho) { // An R environment
SEXP dimXout, x, f, h, R_fcall, fout, foutprov, xout, Fprov;
int i, j, k, ell, d = length(nLev), nout,
*inLev = INTEGER(nLev), *inStar = INTEGER(nStar);
double g, *rF = REAL(F);
// check inputs
if (!isVector(F)) error("'F' must be a vector");
if (!isVector(nLev)) error("'nLev' must be a vector");
if (!isVector(nStar)) error("'nStar' must be a vector");
//if (!isList(xLev)) error("'xLev' must be a list");
if (!isMatrix(Xout)) error("'Xout' must be a matrix");
if (!isFunction(interpCB)) error("'interpCB' must be a function");
if (!isEnvironment(rho)) error("'rho' should be an environment");
F = coerceVector(F, REALSXP);
if (length(nStar) != d + 1) error("'nStar' must be of length 'd + 1'");
if (length(xLev) != d) error("'xLev' must be of length 'd'");
// find the number of output values
PROTECT(dimXout = getAttrib(Xout, R_DimSymbol));
if (INTEGER(dimXout)[1] != d) {
error("number of columns for 'Xout' must be equal to the length of 'nLev'");
}
nout = INTEGER(dimXout)[0];
#ifdef DEBUG
Rprintf("nout = %d\n", nout);
#endif
// prepare SEXP
PROTECT(R_fcall = lang3(interpCB, x, xout));
PROTECT(xout = allocVector(REALSXP, 1));
PROTECT(fout = allocVector(REALSXP, nout));
PROTECT(foutprov = allocVector(REALSXP, 1));
PROTECT(Fprov = allocVector(REALSXP,inStar[d]));
// allocate h to the max used number of levels. Yet the length
// of the R object may be set to a smaller value in the loop
ell = inLev[d - 1];
for (j = d - 2; j >= 0; j--) {
if (inLev[j] > ell) ell = inLev[j];
}
PROTECT(h = allocVector(REALSXP, ell));
double *rFprov = REAL(Fprov);
#ifdef DEBUG
Rprintf("Start loop\n");
#endif
//===========================================================================
// Perform 'd' 1D-interpolations starting from j = d - 1 to j = 0.
//
// o Each Cardinal Basis determination uses two formals 'x' and
// 'xout' IN THAT ORDER!
//
// o Each interpolation has 'xout' of length 1, hence its is a matrix with
// one row.
//
// o Within the j loop, 'Fprov' is an array with dimensions
//
// dim = inLev[0] * inLev[1] * ... * inLev[j]
//
//
//===========================================================================
for (k = 0; k < nout; k++) {
// intialize temporary array 'Fprov' as a slice of 'F'
for (i = 0; i < inStar[d]; i++) {
rFprov[i] = rF[i];
}
for (j = d - 1; j >= 0; j--) {
// pick 'xout' from within 'Xout' and set it as formal #2
REAL(xout)[0] = REAL(Xout)[k + j * nout];
SETCADDR(R_fcall, xout);
// take xLev[[j]] as 'x' for call as the formal #1
SETCADR(R_fcall, VECTOR_ELT(xLev, j));
h = eval(R_fcall, rho);
// SETLENGTH(h, inLev[j]);
#ifdef DEBUG
Rprintf("xout : %6.3f\n", REAL(xout)[0]);
Rprintf("nLev : %6d\n", inLev[j]);
for (ell = 0; ell < inLev[j]; ell++) {
Rprintf("%6.3f ", REAL(VECTOR_ELT(xLev, j))[ell]);
}
Rprintf("\n");
#endif
// this is the 'apply' part
for (i = 0; i < inStar[j]; i++) {
g = 0.0;
for (ell = 0; ell < inLev[j]; ell++) {
g += REAL(h)[ell] * rFprov[i + inStar[j] * ell];
}
rFprov[i] = g;
}
}
REAL(fout)[k] = rFprov[0];
}
UNPROTECT(7);
return(fout);
}
SEXP c_dfRowsToList(SEXP s_df, SEXP s_pars, SEXP s_types, SEXP s_parnames, SEXP s_lens, SEXP s_cnames) {
int *types = INTEGER(s_types);
int npars = LENGTH(s_lens);
int *lens = INTEGER(s_lens);
int nrow_df = LENGTH(VECTOR_ELT(s_df, 0));
int row, par, k; /* loop counters for rows, cols, params, vector param elements */
int type; /* type of column we are currently handling */
int parlen; /* length of param we are currently handling */
int colcount = 0; /* when we iterate params, what is the (first) column of s_df that corresponds? */
SEXP s_res, s_rowlist, s_parval, s_call;
Rboolean all_missing;
/* we iterate thru rows then params. */
s_res = PROTECT(NEW_LIST(nrow_df));
s_call = PROTECT(lang3(install("discreteNameToValue"), R_NilValue, R_NilValue));
for (row = 0; row < nrow_df; row++) {
s_rowlist = PROTECT(NEW_LIST(npars));
/* convert row to R objects and define them in envir s_env */
colcount = 0;
for (par = 0; par < npars; par++) { /* iter thru params */
parlen = lens[par];
type = types[colcount];
all_missing = TRUE;
/* copy vector-param block of row to s_parval */
if (type == 1) { /* numerics */
s_parval = PROTECT(NEW_NUMERIC(parlen));
for (k = 0; k < parlen; k++) {
REAL(s_parval)[k] = REAL(VECTOR_ELT(s_df, colcount+k))[row];
if (!ISNAN(REAL(s_parval)[k]))
all_missing = FALSE;
}
} else if (type == 2) { /* integers */
s_parval = PROTECT(NEW_INTEGER(parlen));
for (k = 0; k < parlen; k++) {
INTEGER(s_parval)[k] = INTEGER(VECTOR_ELT(s_df, colcount+k))[row];
if (INTEGER(s_parval)[k] != NA_INTEGER)
all_missing = FALSE;
}
} else if (type == 3) { /* factors */
s_parval = PROTECT(NEW_CHARACTER(parlen));
for (k = 0; k < parlen; k++) {
SET_STRING_ELT(s_parval, k, STRING_ELT(VECTOR_ELT(s_df, colcount+k), row));
if (STRING_ELT(s_parval, k) != NA_STRING)
all_missing = FALSE;
}
} else if (type == 4) { /* logical */
s_parval = PROTECT(NEW_LOGICAL(parlen));
for (k = 0; k < parlen; k++) {
LOGICAL(s_parval)[k] = LOGICAL(VECTOR_ELT(s_df, colcount+k))[row];
if (LOGICAL(s_parval)[k] != NA_LOGICAL)
all_missing = FALSE;
}
} else if (type == 5) { /* character */
s_parval = PROTECT(NEW_CHARACTER(parlen));
for (k = 0; k < parlen; k++) {
SET_STRING_ELT(s_parval, k, STRING_ELT(VECTOR_ELT(s_df, colcount+k), row));
if (STRING_ELT(s_parval, k) != NA_STRING)
all_missing = FALSE;
}
}
/* are all entries in s_parval NA ? */
if (all_missing)
s_parval = ScalarLogical(NA_LOGICAL);
/* convert discrete names to values */
if (!all_missing && type == 3) {
SETCADR(s_call, VECTOR_ELT(s_pars, par));
SETCADDR(s_call, s_parval);
s_parval = PROTECT(eval(s_call, R_GlobalEnv));
UNPROTECT(1); /* eval */
}
/* only support for cnames for num, int, log and char vecs currently */
if (type == 1 || type == 2 || type == 4 || type == 5)
SET_NAMES(s_parval, VECTOR_ELT(s_cnames, par));
SET_VECTOR_ELT(s_rowlist, par, s_parval);
SET_NAMES(s_rowlist, s_parnames);
colcount += parlen;
UNPROTECT(1); /* s_parval */
}
SET_VECTOR_ELT(s_res, row, s_rowlist);
UNPROTECT(1); /* s_rowlist */
}
UNPROTECT(2); /* s_res, s_call */
return s_res;
}
