/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises.
FUN must be unevaluated for use in e.g. bquote .
*/
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
PROTECT_INDEX px;
checkArity(op, args);
SEXP X, XX, FUN;
PROTECT_WITH_INDEX(X =CAR(args), &px);
XX = PROTECT(eval(CAR(args), rho));
R_xlen_t n = xlength(XX); // a vector, so will be valid.
FUN = CADR(args);
Rboolean realIndx = n > INT_MAX;
SEXP ans = PROTECT(allocVector(VECSXP, n));
SEXP names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP ind = PROTECT(allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP isym = install("i");
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
SEXP tmp = PROTECT(LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
SEXP R_fcall = PROTECT(LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
for(R_xlen_t i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
tmp = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(tmp)) tmp = lazy_duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(6);
return ans;
}
// TODO
static SEXP map_sexp_shortcut_depth_recursive(SEXP (*const f)(SEXP, int), SEXP sexp, const int current_depth) {
switch (TYPEOF(sexp)) { // switch for speed
case NILSXP:
return sexp; // do nothing with nils
case LANGSXP: {
SEXP mapped_sexp = f(sexp, current_depth);
if (sexp == mapped_sexp) // recurse iff the current sexp was not replaced
return LCONS(map_sexp_shortcut_depth_recursive(f, CAR(sexp), current_depth + 1),
map_sexp_shortcut_depth_recursive(f, CDR(sexp), current_depth + 1)); // recurse
else
return mapped_sexp; // shortcut
}
case LISTSXP: { // TODO this is buggy, as intermediates are not PROTECTED. use a for-loop instead
SEXP mapped_sexp = f(sexp, current_depth);
if (sexp == mapped_sexp) // recurse iff the current sexp was not replaced
return CONS(map_sexp_shortcut_depth_recursive(f, CAR(sexp), current_depth + 1),
map_sexp_shortcut_depth_recursive(f, CDR(sexp), current_depth + 1)); // recurse
else
return mapped_sexp; // shortcut
}
default: // base case
return f(sexp, current_depth); // map leafs
}
}
// TODO
SEXP map_sexp_shortcut(SEXP (*const f)(SEXP), SEXP sexp) {
switch (TYPEOF(sexp)) { // switch for speed
case NILSXP:
return sexp; // do nothing with nils
case LANGSXP: {
SEXP mapped_sexp = f(sexp);
if (sexp == mapped_sexp)
return LCONS(map_sexp_shortcut(f, CAR(sexp)),
map_sexp_shortcut(f, CDR(sexp))); // recurse
else
return mapped_sexp; // shortcut
}
case LISTSXP: { // TODO this is buggy, as intermediates are not PROTECTED. use a for-loop instead
SEXP mapped_sexp = f(sexp);
if (sexp == mapped_sexp)
return CONS(map_sexp_shortcut(f, CAR(sexp)),
map_sexp_shortcut(f, CDR(sexp))); // recurse
else
return mapped_sexp; // shortcut
}
default: // base case
return f(sexp); // map leafs
}
}
INLINE_FUN SEXP lang1(SEXP s)
{
return LCONS(s, R_NilValue);
}
SEXP deriv(SEXP args)
{
/* deriv(expr, namevec, function.arg, tag, hessian) */
SEXP ans, ans2, expr, funarg, names, s;
int f_index, *d_index, *d2_index;
int i, j, k, nexpr, nderiv=0, hessian;
SEXP exprlist, tag;
args = CDR(args);
InitDerivSymbols();
PROTECT(exprlist = LCONS(R_BraceSymbol, R_NilValue));
/* expr: */
if (isExpression(CAR(args)))
PROTECT(expr = VECTOR_ELT(CAR(args), 0));
else PROTECT(expr = CAR(args));
args = CDR(args);
/* namevec: */
names = CAR(args);
if (!isString(names) || (nderiv = length(names)) < 1)
error(_("invalid variable names"));
args = CDR(args);
/* function.arg: */
funarg = CAR(args);
args = CDR(args);
/* tag: */
tag = CAR(args);
if (!isString(tag) || length(tag) < 1
|| length(STRING_ELT(tag, 0)) < 1 || length(STRING_ELT(tag, 0)) > 60)
error(_("invalid tag"));
args = CDR(args);
/* hessian: */
hessian = asLogical(CAR(args));
/* NOTE: FindSubexprs is destructive, hence the duplication.
It can allocate, so protect the duplicate.
*/
PROTECT(ans = duplicate(expr));
f_index = FindSubexprs(ans, exprlist, tag);
d_index = (int*)R_alloc((size_t) nderiv, sizeof(int));
if (hessian)
d2_index = (int*)R_alloc((size_t) ((nderiv * (1 + nderiv))/2),
sizeof(int));
else d2_index = d_index;/*-Wall*/
UNPROTECT(1);
for(i=0, k=0; i<nderiv ; i++) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
PROTECT(ans2 = duplicate(ans)); /* keep a temporary copy */
d_index[i] = FindSubexprs(ans, exprlist, tag); /* examine the derivative first */
PROTECT(ans = duplicate(ans2)); /* restore the copy */
if (hessian) {
for(j = i; j < nderiv; j++) {
PROTECT(ans2 = duplicate(ans)); /* install could allocate */
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
d2_index[k] = FindSubexprs(ans2, exprlist, tag);
k++;
UNPROTECT(2);
}
}
UNPROTECT(4);
}
nexpr = length(exprlist) - 1;
if (f_index) {
Accumulate2(MakeVariable(f_index, tag), exprlist);
}
else {
PROTECT(ans = duplicate(expr));
Accumulate2(expr, exprlist);
UNPROTECT(1);
}
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
for (i = 0, k = 0; i < nderiv ; i++) {
if (d_index[i]) {
Accumulate2(MakeVariable(d_index[i], tag), exprlist);
if (hessian) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
UNPROTECT(2);
}
} else { /* the first derivative is constant or simple variable */
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
Accumulate2(ans, exprlist);
UNPROTECT(2);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
if(isZero(ans2)) Accumulate2(R_MissingArg, exprlist);
else Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
}
}
}
Accumulate2(R_NilValue, exprlist);
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
i = 0;
ans = CDR(exprlist);
while (i < nexpr) {
if (CountOccurrences(MakeVariable(i+1, tag), CDR(ans)) < 2) {
SETCDR(ans, Replace(MakeVariable(i+1, tag), CAR(ans), CDR(ans)));
SETCAR(ans, R_MissingArg);
}
else {
SEXP var;
PROTECT(var = MakeVariable(i+1, tag));
SETCAR(ans, lang3(install("<-"), var, AddParens(CAR(ans))));
UNPROTECT(1);
}
i = i + 1;
ans = CDR(ans);
}
/* .value <- ... */
SETCAR(ans, lang3(install("<-"), install(".value"), AddParens(CAR(ans))));
ans = CDR(ans);
/* .grad <- ... */
SETCAR(ans, CreateGrad(names));
ans = CDR(ans);
/* .hessian <- ... */
if (hessian) { SETCAR(ans, CreateHess(names)); ans = CDR(ans); }
/* .grad[, "..."] <- ... */
for (i = 0; i < nderiv ; i++) {
SETCAR(ans, DerivAssign(STRING_ELT(names, i), AddParens(CAR(ans))));
ans = CDR(ans);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (CAR(ans) != R_MissingArg) {
if (i == j) {
SETCAR(ans, HessAssign1(STRING_ELT(names, i),
AddParens(CAR(ans))));
} else {
SETCAR(ans, HessAssign2(STRING_ELT(names, i),
STRING_ELT(names, j),
AddParens(CAR(ans))));
}
}
ans = CDR(ans);
}
}
}
/* attr(.value, "gradient") <- .grad */
SETCAR(ans, AddGrad());
ans = CDR(ans);
if (hessian) { SETCAR(ans, AddHess()); ans = CDR(ans); }
/* .value */
SETCAR(ans, install(".value"));
/* Prune the expression list removing eliminated sub-expressions */
SETCDR(exprlist, Prune(CDR(exprlist)));
if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */
funarg = names;
}
if (TYPEOF(funarg) == CLOSXP)
{
funarg = mkCLOSXP(FORMALS(funarg), exprlist, CLOENV(funarg));
}
else if (isString(funarg)) {
SEXP formals = allocList(length(funarg));
ans = formals;
for(i = 0; i < length(funarg); i++) {
SET_TAG(ans, installTrChar(STRING_ELT(funarg, i)));
SETCAR(ans, R_MissingArg);
ans = CDR(ans);
}
funarg = mkCLOSXP(formals, exprlist, R_GlobalEnv);
}
else {
funarg = allocVector(EXPRSXP, 1);
SET_VECTOR_ELT(funarg, 0, exprlist);
/* funarg = lang2(install("expression"), exprlist); */
}
UNPROTECT(2);
return funarg;
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; // -Wall
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
dim_v = getAttrib(value, R_DimSymbol);
array_value = CXXRCONSTRUCT(Rboolean, (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1));
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(ind = allocVector(INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
val = eval(R_fcall, rho);
if (NAMED(val))
val = duplicate(val);
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
bool okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
default:
Rf_error(_("Internal error: unexpected SEXPTYPE"));
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
for (int j = 0; j < commonLen; j++) {
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(val)[j]; break;
case REALSXP: REAL(ans)[i*commonLen + j] = REAL(val)[j]; break;
case INTSXP: INTEGER(ans)[i*commonLen + j] = INTEGER(val)[j]; break;
case LGLSXP: LOGICAL(ans)[i*commonLen + j] = LOGICAL(val)[j]; break;
case RAWSXP: RAW(ans)[i*commonLen + j] = RAW(val)[j]; break;
case STRSXP: SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(val, j)); break;
case VECSXP: SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(val, j)); break;
default:
error(_("type '%s' is not supported"), type2char(commonType));
}
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = int( n); // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi)
{
int nprotect = 0;
SEXP Pnames, Snames;
SEXP x = R_NilValue;
int *dim;
int npar, nrep, nvar, ns;
int definit;
int xdim[2];
const char *dimnms[2] = {"variable","rep"};
ns = *(INTEGER(AS_INTEGER(nsim)));
PROTECT(params = as_matrix(params)); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
dim = INTEGER(GET_DIM(params));
npar = dim[0]; nrep = dim[1];
if (ns % nrep != 0)
errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')");
definit = *(INTEGER(GET_SLOT(object,install("default.init"))));
if (definit) { // default initializer
SEXP fcall, pat, repl, val, ivpnames, statenames;
int *pidx, j, k;
double *xp, *pp;
PROTECT(pat = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(pat,0,mkChar("\\.0$"));
PROTECT(repl = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(repl,0,mkChar(""));
PROTECT(val = NEW_LOGICAL(1)); nprotect++;
*(INTEGER(val)) = 1;
// extract names of IVPs
PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++;
SET_TAG(fcall,install("value"));
PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++;
PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++;
nvar = LENGTH(ivpnames);
if (nvar < 1) {
errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'.");
}
pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++;
for (k = 0; k < nvar; k++) pidx[k]--;
// construct names of state variables
PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(repl,fcall)); nprotect++;
SET_TAG(fcall,install("replacement"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++;
PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++;
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,statenames,2);
fixdimnames(x,dimnms,2);
for (j = 0, xp = REAL(x); j < ns; j++) {
pp = REAL(params) + npar*(j%nrep);
for (k = 0; k < nvar; k++, xp++)
*xp = pp[pidx[k]];
}
} else { // user-supplied initializer
SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue;
pompfunmode mode = undef;
double *cp = NULL;
// extract the initializer function and its environment
PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract covariates and interpolate
PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++;
if (LENGTH(tcovar) > 0) { // do table lookup
PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++;
PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++;
cp = REAL(covars);
}
// extract userdata
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
switch (mode) {
case Rfun: // use R function
{
SEXP par, rho, x1, x2;
double *p, *pp, *xp, *xt;
int j, *midx;
// extract covariates and interpolate
if (LENGTH(tcovar) > 0) { // add covars to call
PROTECT(fcall = LCONS(covars,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
}
// parameter vector
PROTECT(par = NEW_NUMERIC(npar)); nprotect++;
SET_NAMES(par,Pnames);
pp = REAL(par);
// finish constructing the call
PROTECT(fcall = LCONS(t0,fcall)); nprotect++;
SET_TAG(fcall,install("t0"));
PROTECT(fcall = LCONS(par,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// evaluation environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
p = REAL(params);
memcpy(pp,p,npar*sizeof(double)); // copy the parameters
PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call
PROTECT(Snames = GET_NAMES(x1)); nprotect++;
if (!IS_NUMERIC(x1) || isNull(Snames)) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector");
}
nvar = LENGTH(x1);
xp = REAL(x1);
midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++;
for (j = 0; j < nvar; j++) {
if (midx[j]!=0) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j)));
}
}
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
xt = REAL(x);
memcpy(xt,xp,nvar*sizeof(double));
for (j = 1, xt += nvar; j < ns; j++, xt += nvar) {
memcpy(pp,p+npar*(j%nrep),npar*sizeof(double));
PROTECT(x2 = eval(fcall,rho));
xp = REAL(x2);
if (LENGTH(x2)!=nvar)
errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length");
memcpy(xt,xp,nvar*sizeof(double));
UNPROTECT(1);
}
}
break;
case native: // use native routine
{
SEXP Cnames;
int *sidx, *pidx, *cidx;
double *xt, *ps, time;
pomp_initializer *ff = NULL;
int j;
PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
// construct state, parameter, covariate, observable indices
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
nvar = LENGTH(Snames);
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
set_pomp_userdata(fcall);
GetRNGstate();
time = *(REAL(t0));
// loop over replicates
for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar)
(*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp);
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov
break;
}
}
UNPROTECT(nprotect);
return x;
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; /* initialize to avoid a warning */
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = n > INT_MAX;
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
// check once here
if (commonType != CPLXSXP && commonType != REALSXP &&
commonType != INTSXP && commonType != LGLSXP &&
commonType != RAWSXP && commonType != STRSXP &&
commonType != VECSXP)
error(_("type '%s' is not supported"), type2char(commonType));
dim_v = getAttrib(value, R_DimSymbol);
array_value = (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1);
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP isym = install("i");
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(tmp = LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
int common_len_offset = 0;
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
val = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(val))
val = lazy_duplicate(val); // Need to duplicate? Copying again anyway
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
Rboolean okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
// two cases - only for efficiency
if(commonLen == 1) { // common case
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i] = COMPLEX(val)[0]; break;
case REALSXP: REAL(ans) [i] = REAL (val)[0]; break;
case INTSXP: INTEGER(ans)[i] = INTEGER(val)[0]; break;
case LGLSXP: LOGICAL(ans)[i] = LOGICAL(val)[0]; break;
case RAWSXP: RAW(ans) [i] = RAW (val)[0]; break;
case STRSXP: SET_STRING_ELT(ans, i, STRING_ELT(val, 0)); break;
case VECSXP: SET_VECTOR_ELT(ans, i, VECTOR_ELT(val, 0)); break;
}
} else { // commonLen > 1 (typically, or == 0) :
switch (commonType) {
case REALSXP:
memcpy(REAL(ans) + common_len_offset,
REAL(val), commonLen * sizeof(double)); break;
case INTSXP:
memcpy(INTEGER(ans) + common_len_offset,
INTEGER(val), commonLen * sizeof(int)); break;
case LGLSXP:
memcpy(LOGICAL(ans) + common_len_offset,
LOGICAL(val), commonLen * sizeof(int)); break;
case RAWSXP:
memcpy(RAW(ans) + common_len_offset,
RAW(val), commonLen * sizeof(Rbyte)); break;
case CPLXSXP:
memcpy(COMPLEX(ans) + common_len_offset,
COMPLEX(val), commonLen * sizeof(Rcomplex)); break;
case STRSXP:
for (int j = 0; j < commonLen; j++)
SET_STRING_ELT(ans, common_len_offset + j, STRING_ELT(val, j));
break;
case VECSXP:
for (int j = 0; j < commonLen; j++)
SET_VECTOR_ELT(ans, common_len_offset + j, VECTOR_ELT(val, j));
break;
}
common_len_offset += commonLen;
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = (int) n; // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
SEXP mutate_subtrees(SEXP sexp,
double p, double p_insert_delete,
SEXP function_symbol_list,
SEXP function_arities,
SEXP input_variable_list,
double constant_min, double constant_max,
double p_subtree, double p_constant,
int depth_max) {
// Rprintf("->\n"); // DEBUG
switch (TYPEOF(sexp)) { // switch for speed
case NILSXP:
return sexp; // do nothing with nils
case LANGSXP:
if (unif_rand() < p) { // mutate inner node with probability p
if (unif_rand() < p_insert_delete) { // replace with new subtree (insert)
// Rprintf("insert\n"); // DEBUG
SEXP new_subtree = PROTECT(initialize_expression_grow(function_symbol_list, function_arities,
input_variable_list,
constant_min, constant_max,
p_subtree, p_constant,
depth_max));
UNPROTECT(1);
return new_subtree;
} else { // replace with new leaf (delete)
// Rprintf("delete\n"); // DEBUG
SEXP new_leaf = PROTECT(initialize_expression_grow(function_symbol_list, function_arities,
input_variable_list,
constant_min, constant_max,
p_subtree, p_constant,
0));
UNPROTECT(1);
return new_leaf;
}
} else {
// Rprintf("pass\n"); // DEBUG
int function_arity = 0;
SEXP e;
PROTECT(e = R_NilValue);
for (SEXP iterator = CDR(sexp); !isNull(iterator); iterator = CDR(iterator)) { // recurse on actual parameters
function_arity++; // determine arity on the fly
SEXP mutated_parameter;
PROTECT(mutated_parameter = mutate_subtrees(CAR(iterator), p, p_insert_delete,
function_symbol_list, function_arities,
input_variable_list,
constant_min, constant_max,
p_subtree, p_constant,
depth_max));
PROTECT(e = CONS(mutated_parameter, e));
}
PROTECT(e = LCONS(CAR(sexp), e));
UNPROTECT(2 * function_arity + 2);
return e;
}
case LISTSXP:
error("mutate_subtrees: unexpected LISTSXP");
default: // base case
// Rprintf("default type %d\n", TYPEOF(sexp)); // DEBUG
// if (REALSXP == TYPEOF(sexp)) {
// Rprintf("real %f\n", REAL(sexp)[0]); // DEBUG
// }
// if (SYMSXP == TYPEOF(sexp)) {
// Rprintf("symbol %s\n", CHAR(PRINTNAME(sexp))); // DEBUG
// }
if (unif_rand() < p) { // mutate leaf with probability p
if (unif_rand() < p_insert_delete) { // replace with new subtree (insert)
// Rprintf("insert at default\n"); // DEBUG
SEXP new_subtree;
new_subtree = PROTECT(initialize_expression_grow(function_symbol_list, function_arities,
input_variable_list,
constant_min, constant_max,
p_subtree, p_constant,
depth_max));
UNPROTECT(1);
return new_subtree;
} else { // replace with new leaf (delete)
// Rprintf("delete at default\n"); // DEBUG
SEXP new_leaf;
new_leaf = PROTECT(initialize_expression_grow(function_symbol_list, function_arities,
input_variable_list,
constant_min, constant_max,
p_subtree, p_constant,
0));
UNPROTECT(1);
return new_leaf;
}
} else {
// Rprintf("pass at default\n"); // DEBUG
return sexp; // do nothing
}
}
}
// (C) ceeboo 2013/12
//
// Wrapper for simple triplet matrix which runs in constant
// memory.
SEXP _col_apply_stm(SEXP a) {
a = CDR(a);
if (length(a) < 2)
error("invalid number of arguments");
SEXP x = CAR(a);
if (!inherits(x, "simple_triplet_matrix") || _valid_stm(x))
error("'x' not of class 'simple_triplet_matrix'");
if (!isFunction(CADR(a)))
error("invalid function parameter");
int n, m, *_ix, *_jx, *_nx, *_px;
SEXP vx, z, r;
vx = VECTOR_ELT(x, 2);
n = INTEGER(VECTOR_ELT(x, 3))[0];
m = INTEGER(VECTOR_ELT(x, 4))[0];
z = PROTECT(allocVector(TYPEOF(vx), n));
a = PROTECT(LCONS(CADR(a), LCONS(z, CDDR(a))));
switch(TYPEOF(vx)) {
case LGLSXP:
case INTSXP:
memset(INTEGER(z), 0, sizeof(int) * n);
break;
case REALSXP:
memset(REAL(z), 0, sizeof(double) * n);
break;
case RAWSXP:
memset(RAW(z), 0, sizeof(char) * n);
break;
case CPLXSXP:
memset(COMPLEX(z), 0, sizeof(Rcomplex) * n);
break;
case EXPRSXP:
case VECSXP:
for (int i = 0; i < n; i++)
SET_VECTOR_ELT(z, i, R_NilValue);
break;
case STRSXP:
for (int i = 0; i < n; i++)
SET_STRING_ELT(z, i, R_BlankString);
break;
default:
error("type of 'v' not supported");
}
// Map blocks of equal column indexes
_jx = INTEGER(VECTOR_ELT(x, 1)); // column indexes
_nx = INTEGER(PROTECT(allocVector(INTSXP, m + 1)));
memset(_nx, 0, sizeof(int) * (m + 1));
for (int k = 0; k < LENGTH(vx); k++)
_nx[_jx[k]]++;
for (int k = 1; k < m + 1; k++)
_nx[k] += _nx[k-1];
_px = INTEGER(PROTECT(allocVector(INTSXP, LENGTH(vx))));
_nx -= 1; // one-based R indexing
for (int k = 0; k < LENGTH(vx); k++) {
_px[_nx[_jx[k]]] = k;
_nx[_jx[k]]++;
}
// Reset
_nx += 1;
for (int k = m; k > 0; k--)
_nx[k] = _nx[k-1];
_nx[0] = 0;
_ix = INTEGER(VECTOR_ELT(x, 0)); // row indexes
r = PROTECT(allocVector(VECSXP, m));
int f, fl;
f = fl = _nx[0];
for (int i = 1; i < m + 1; i++) {
int l = _nx[i];
// (Re)set values
switch(TYPEOF(vx)) {
case LGLSXP:
case INTSXP:
for (int k = fl; k < f; k++)
INTEGER(z)[_px[k]] = 0;
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
INTEGER(z)[i] = INTEGER(vx)[p];
_px[k] = i;
}
break;
case REALSXP:
for (int k = fl; k < f; k++)
REAL(z)[_px[k]] = 0.0;
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
REAL(z)[i] = REAL(vx)[p];
_px[k] = i;
}
break;
case RAWSXP:
for (int k = fl; k < f; k++)
RAW(z)[_px[k]] = (char) 0;
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
RAW(z)[i] = RAW(vx)[p];
_px[k] = i;
}
break;
case CPLXSXP:
for (int k = fl; k < f; k++) {
static Rcomplex c;
COMPLEX(z)[_px[k]] = c;
}
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
COMPLEX(z)[i] = COMPLEX(vx)[p];
_px[k] = i;
}
break;
case EXPRSXP:
case VECSXP:
for (int k = fl; k < f; k++)
SET_VECTOR_ELT(z, _px[k], R_NilValue);
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
SET_VECTOR_ELT(z, i, VECTOR_ELT(vx, p));
_px[k] = i;
}
break;
case STRSXP:
for (int k = fl; k < f; k++)
SET_STRING_ELT(z, _px[k], R_BlankString);
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
SET_STRING_ELT(z, i, STRING_ELT(vx, p));
_px[k] = i;
}
break;
default:
error("type of 'v' not supported");
}
SEXP s = eval(a, R_GlobalEnv);
if (s == z) // identity, print, ...
SET_VECTOR_ELT(r, i - 1, duplicate(s));
else
SET_VECTOR_ELT(r, i - 1, s);
fl = f;
f = l;
}
UNPROTECT(5);
return r;
}
SEXP do_partrans (SEXP object, SEXP params, SEXP dir, SEXP gnsi)
{
int nprotect = 0;
SEXP fn, fcall, rho, ans, nm;
SEXP pdim, pvec;
SEXP pompfun;
SEXP tparams = R_NilValue;
pompfunmode mode = undef;
char direc;
int qmat;
int ndim[2], *dim, *idx;
double *pp, *ps, *pt, *pa;
int npar1, npar2, nreps;
pomp_transform_fn *ff = NULL;
int k;
direc = *(INTEGER(dir));
// extract the user-defined function
switch (direc) {
case 1: // forward transformation
PROTECT(pompfun = GET_SLOT(object,install("from.trans"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
break;
case -1: // inverse transformation
PROTECT(pompfun = GET_SLOT(object,install("to.trans"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
break;
default:
error("impossible error");
break;
}
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
PROTECT(pdim = GET_DIM(params)); nprotect++;
if (isNull(pdim)) { // a single vector
npar1 = LENGTH(params); nreps = 1;
qmat = 0;
} else { // a parameter matrix
dim = INTEGER(pdim);
npar1 = dim[0]; nreps = dim[1];
qmat = 1;
}
switch (mode) {
case Rfun: // use user-supplied R function
// set up the function call
if (qmat) { // matrix case
PROTECT(pvec = NEW_NUMERIC(npar1)); nprotect++;
SET_NAMES(pvec,GET_ROWNAMES(GET_DIMNAMES(params)));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
} else { // vector case
PROTECT(fcall = LCONS(params,fcall)); nprotect++;
}
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
if (qmat) { // matrix case
const char *dimnm[2] = {"variable","rep"};
ps = REAL(params);
pp = REAL(pvec);
memcpy(pp,ps,npar1*sizeof(double));
PROTECT(ans = eval(fcall,rho)); nprotect++;
PROTECT(nm = GET_NAMES(ans)); nprotect++;
if (isNull(nm))
error("user transformation functions must return a named numeric vector");
// set up matrix to hold the results
npar2 = LENGTH(ans);
ndim[0] = npar2; ndim[1] = nreps;
PROTECT(tparams = makearray(2,ndim)); nprotect++;
setrownames(tparams,nm,2);
fixdimnames(tparams,dimnm,2);
pt = REAL(tparams);
pa = REAL(AS_NUMERIC(ans));
memcpy(pt,pa,npar2*sizeof(double));
ps += npar1;
pt += npar2;
for (k = 1; k < nreps; k++, ps += npar1, pt += npar2) {
memcpy(pp,ps,npar1*sizeof(double));
pa = REAL(AS_NUMERIC(eval(fcall,rho)));
memcpy(pt,pa,npar2*sizeof(double));
}
} else { // vector case
PROTECT(tparams = eval(fcall,rho)); nprotect++;
if (isNull(GET_NAMES(tparams)))
error("user transformation functions must return a named numeric vector");
}
break;
case native: // use native routine
ff = (pomp_transform_fn *) R_ExternalPtrAddr(fn);
if (qmat) {
idx = INTEGER(PROTECT(name_index(GET_ROWNAMES(GET_DIMNAMES(params)),pompfun,"paramnames"))); nprotect++;
} else {
idx = INTEGER(PROTECT(name_index(GET_NAMES(params),pompfun,"paramnames"))); nprotect++;
}
set_pomp_userdata(fcall);
PROTECT(tparams = duplicate(params)); nprotect++;
for (k = 0, ps = REAL(params), pt = REAL(tparams); k < nreps; k++, ps += npar1, pt += npar1) {
R_CheckUserInterrupt();
(*ff)(pt,ps,idx);
}
unset_pomp_userdata();
break;
default:
error("unrecognized 'mode' slot in 'partrans'");
}
UNPROTECT(nprotect);
return tparams;
}
SEXP do_rprocess (SEXP object, SEXP xstart, SEXP times, SEXP params, SEXP offset, SEXP gnsi)
{
int nprotect = 0;
int *xdim, nvars, npars, nreps, nrepsx, ntimes, off;
SEXP X, Xoff, copy, fn, fcall, rho;
SEXP dimXstart, dimP, dimX;
PROTECT(gnsi = duplicate(gnsi)); nprotect++;
ntimes = length(times);
if (ntimes < 2) {
error("rprocess error: length(times)==0: no transitions, no work to do");
}
off = *(INTEGER(AS_INTEGER(offset)));
if ((off < 0)||(off>=ntimes))
error("illegal 'offset' value %d",off);
PROTECT(xstart = as_matrix(xstart)); nprotect++;
PROTECT(dimXstart = GET_DIM(xstart)); nprotect++;
xdim = INTEGER(dimXstart);
nvars = xdim[0]; nrepsx = xdim[1];
PROTECT(params = as_matrix(params)); nprotect++;
PROTECT(dimP = GET_DIM(params)); nprotect++;
xdim = INTEGER(dimP);
npars = xdim[0]; nreps = xdim[1];
if (nrepsx > nreps) { // more ICs than parameters
if (nrepsx % nreps != 0) {
error("rprocess error: larger number of replicates is not a multiple of smaller");
} else {
double *src, *tgt;
int dims[2];
int j, k;
dims[0] = npars; dims[1] = nrepsx;
PROTECT(copy = duplicate(params)); nprotect++;
PROTECT(params = makearray(2,dims)); nprotect++;
setrownames(params,GET_ROWNAMES(GET_DIMNAMES(copy)),2);
src = REAL(copy);
tgt = REAL(params);
for (j = 0; j < nrepsx; j++) {
for (k = 0; k < npars; k++, tgt++) {
*tgt = src[k+npars*(j%nreps)];
}
}
}
nreps = nrepsx;
} else if (nrepsx < nreps) { // more parameters than ICs
if (nreps % nrepsx != 0) {
error("rprocess error: larger number of replicates is not a multiple of smaller");
} else {
double *src, *tgt;
int dims[2];
int j, k;
dims[0] = nvars; dims[1] = nreps;
PROTECT(copy = duplicate(xstart)); nprotect++;
PROTECT(xstart = makearray(2,dims)); nprotect++;
setrownames(xstart,GET_ROWNAMES(GET_DIMNAMES(copy)),2);
src = REAL(copy);
tgt = REAL(xstart);
for (j = 0; j < nreps; j++) {
for (k = 0; k < nvars; k++, tgt++) {
*tgt = src[k+nvars*(j%nrepsx)];
}
}
}
}
// extract the process function
PROTECT(fn = GET_SLOT(object,install("rprocess"))); nprotect++;
// construct the call
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
PROTECT(fcall = LCONS(gnsi,fcall)); nprotect++;
SET_TAG(fcall,install(".getnativesymbolinfo"));
PROTECT(fcall = LCONS(GET_SLOT(object,install("zeronames")),fcall)); nprotect++;
SET_TAG(fcall,install("zeronames"));
PROTECT(fcall = LCONS(GET_SLOT(object,install("covar")),fcall)); nprotect++;
SET_TAG(fcall,install("covar"));
PROTECT(fcall = LCONS(GET_SLOT(object,install("tcovar")),fcall)); nprotect++;
SET_TAG(fcall,install("tcovar"));
PROTECT(fcall = LCONS(params,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(AS_NUMERIC(times),fcall)); nprotect++;
SET_TAG(fcall,install("times"));
PROTECT(fcall = LCONS(xstart,fcall)); nprotect++;
SET_TAG(fcall,install("xstart"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
PROTECT(rho = (CLOENV(fn))); nprotect++; // environment of the function
PROTECT(X = eval(fcall,rho)); nprotect++; // do the call
PROTECT(dimX = GET_DIM(X)); nprotect++;
if ((isNull(dimX)) || (length(dimX) != 3)) {
error("rprocess error: user 'rprocess' must return a rank-3 array");
}
xdim = INTEGER(dimX);
if ((xdim[0] != nvars) || (xdim[1] != nreps) || (xdim[2] != ntimes)) {
error("rprocess error: user 'rprocess' must return a %d x %d x %d array",nvars,nreps,ntimes);
}
if (isNull(GET_ROWNAMES(GET_DIMNAMES(X)))) {
error("rprocess error: user 'rprocess' must return an array with rownames");
}
if (off > 0) {
xdim[2] -= off;
PROTECT(Xoff = makearray(3,xdim)); nprotect++;
setrownames(Xoff,GET_ROWNAMES(GET_DIMNAMES(X)),3);
memcpy(REAL(Xoff),REAL(X)+off*nvars*nreps,(ntimes-off)*nvars*nreps*sizeof(double));
UNPROTECT(nprotect);
return Xoff;
} else {
UNPROTECT(nprotect);
return X;
}
}
static Rboolean latin1locale(void) {
return *LOGICAL(VECTOR_ELT(eval(LCONS(install("l10n_info"), R_NilValue),
R_GlobalEnv), 2));
}
SEXP euler_model_simulator (SEXP func,
SEXP xstart, SEXP times, SEXP params,
SEXP deltat, SEXP method, SEXP zeronames,
SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen;
int nstep = 0;
double dt, dtt;
SEXP X;
SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue;
SEXP Snames, Pnames, Cnames;
SEXP cvec, tvec = R_NilValue;
SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue;
int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0;
pomp_onestep_sim *ff = NULL;
int meth = INTEGER_VALUE(method);
// meth: 0 = Euler, 1 = one-step, 2 = fixed step
dtt = NUMERIC_VALUE(deltat);
if (dtt <= 0)
errorcall(R_NilValue,"'delta.t' should be a positive number");
{
int *dim;
dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1];
dim = INTEGER(GET_DIM(params)); npars = dim[0];
dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1];
ntimes = LENGTH(times);
}
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++;
// set up the covariate table
struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)};
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
// indices of accumulator variables
nzeros = LENGTH(zeronames);
zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++;
// extract user function
PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;
// set up
switch (mode) {
case Rfun: // R function
PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,args)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++;
SET_TAG(fcall,install("delta.t"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate indices
sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
// create array to hold results
{
int dim[3] = {nvars, nreps, ntimes};
PROTECT(X = makearray(3,dim)); nprotect++;
setrownames(X,Snames,3);
}
// copy the start values into the result array
memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double));
if (mode==1) {
set_pomp_userdata(args);
GetRNGstate();
}
// now do computations
{
int first = 1;
int use_names = 0;
int *posn = 0;
double *time = REAL(times);
double *xs = REAL(X);
double *xt = REAL(X)+nvars*nreps;
double *cp = REAL(cvec);
double *ps = REAL(params);
double t = time[0];
double *pm, *xm;
int i, j, k, step;
for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) {
R_CheckUserInterrupt();
if (t > time[step]) {
errorcall(R_NilValue,"'times' is not an increasing sequence");
}
memcpy(xt,xs,nreps*nvars*sizeof(double));
// set accumulator variables to zero
for (j = 0; j < nreps; j++)
for (i = 0; i < nzeros; i++)
xt[zidx[i]+nvars*j] = 0.0;
switch (meth) {
case 0: // Euler method
dt = dtt;
nstep = num_euler_steps(t,time[step],&dt);
break;
case 1: // one step
dt = time[step]-t;
nstep = (dt > 0) ? 1 : 0;
break;
case 2: // fixed step
dt = dtt;
nstep = num_map_steps(t,time[step],dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'method'"); // # nocov
break;
}
for (k = 0; k < nstep; k++) { // loop over Euler steps
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,t,cp);
for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates
switch (mode) {
case Rfun: // R function
{
double *xp = REAL(xvec);
double *pp = REAL(pvec);
double *tp = REAL(tvec);
double *dtp = REAL(dtvec);
double *ap;
*tp = t;
*dtp = dt;
memcpy(xp,xm,nvars*sizeof(double));
memcpy(pp,pm,npars*sizeof(double));
if (first) {
PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call
if (LENGTH(ans) != nvars) {
errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?",
LENGTH(ans),nvars);
}
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) {
posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
}
ap = REAL(AS_NUMERIC(ans));
first = 0;
} else {
ap = REAL(AS_NUMERIC(eval(fcall,rho)));
}
if (use_names) {
for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i];
} else {
for (i = 0; i < nvars; i++) xm[i] = ap[i];
}
}
break;
case native: // native code
(*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
}
t += dt;
if ((meth == 0) && (k == nstep-2)) { // penultimate step
dt = time[step]-t;
t = time[step]-dt;
}
}
}
}
if (mode==1) {
PutRNGstate();
unset_pomp_userdata();
}
UNPROTECT(nprotect);
return X;
}
// compute pdf of a sequence of Euler steps
SEXP euler_model_density (SEXP func,
SEXP x, SEXP times, SEXP params,
SEXP tcovar, SEXP covar, SEXP log, SEXP args, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int give_log;
int nvars, npars, nreps, ntimes, ncovars, covlen;
pomp_onestep_pdf *ff = NULL;
SEXP cvec, pvec = R_NilValue;
SEXP t1vec = R_NilValue, t2vec = R_NilValue;
SEXP x1vec = R_NilValue, x2vec = R_NilValue;
SEXP Snames, Pnames, Cnames;
SEXP fn, rho = R_NilValue, fcall = R_NilValue;
SEXP F;
int *pidx = 0, *sidx = 0, *cidx = 0;
{
int *dim;
dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nreps = dim[1];
dim = INTEGER(GET_DIM(params)); npars = dim[0];
dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1];
ntimes = LENGTH(times);
}
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++;
// set up the covariate table
struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)};
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;
give_log = *(INTEGER(log));
switch (mode) {
case Rfun: // R function
PROTECT(t1vec = NEW_NUMERIC(1)); nprotect++;
PROTECT(t2vec = NEW_NUMERIC(1)); nprotect++;
PROTECT(x1vec = NEW_NUMERIC(nvars)); nprotect++;
SET_NAMES(x1vec,Snames);
PROTECT(x2vec = NEW_NUMERIC(nvars)); nprotect++;
SET_NAMES(x2vec,Snames);
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,args)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(t2vec,fcall)); nprotect++;
SET_TAG(fcall,install("t2"));
PROTECT(fcall = LCONS(t1vec,fcall)); nprotect++;
SET_TAG(fcall,install("t1"));
PROTECT(fcall = LCONS(x2vec,fcall)); nprotect++;
SET_TAG(fcall,install("x2"));
PROTECT(fcall = LCONS(x1vec,fcall)); nprotect++;
SET_TAG(fcall,install("x1"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate indices
sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
// create array to hold results
{
int dim[2] = {nreps, ntimes-1};
PROTECT(F = makearray(2,dim)); nprotect++;
}
switch (mode) {
case Rfun: // R function
{
double *cp = REAL(cvec);
double *t1p = REAL(t1vec);
double *t2p = REAL(t2vec);
double *x1p = REAL(x1vec);
double *x2p = REAL(x2vec);
double *pp = REAL(pvec);
double *t1s = REAL(times);
double *t2s = t1s+1;
double *x1s = REAL(x);
double *x2s = x1s + nvars*nreps;
double *ps;
double *fs = REAL(F);
int j, k;
for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times
R_CheckUserInterrupt();
*t1p = *t1s; *t2p = *t2s;
// interpolate the covariates at time t1, store the results in cvec
table_lookup(&covariate_table,*t1p,cp);
for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates
memcpy(x1p,x1s,nvars*sizeof(double));
memcpy(x2p,x2s,nvars*sizeof(double));
memcpy(pp,ps,npars*sizeof(double));
*fs = *(REAL(AS_NUMERIC(eval(fcall,rho))));
if (!give_log) *fs = exp(*fs);
}
}
}
break;
case native: // native code
set_pomp_userdata(args);
{
double *t1s = REAL(times);
double *t2s = t1s+1;
double *x1s = REAL(x);
double *x2s = x1s + nvars*nreps;
double *fs = REAL(F);
double *cp = REAL(cvec);
double *ps;
int j, k;
for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times
R_CheckUserInterrupt();
// interpolate the covariates at time t1, store the results in cvec
table_lookup(&covariate_table,*t1s,cp);
for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates
(*ff)(fs,x1s,x2s,*t1s,*t2s,ps,sidx,pidx,cidx,ncovars,cp);
if (!give_log) *fs = exp(*fs);
}
}
}
unset_pomp_userdata();
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
UNPROTECT(nprotect);
return F;
}
SEXP do_rmeasure (SEXP object, SEXP x, SEXP times, SEXP params, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
SEXP cvec, tvec = R_NilValue, xvec = R_NilValue, pvec = R_NilValue;
SEXP fn, fcall, rho = R_NilValue, ans, nm;
SEXP pompfun;
SEXP Y;
int *dim;
int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0;
struct lookup_table covariate_table;
pomp_measure_model_simulator *ff = NULL;
PROTECT(times = AS_NUMERIC(times)); nprotect++;
ntimes = length(times);
if (ntimes < 1)
errorcall(R_NilValue,"in 'rmeasure': length('times') = 0, no work to do");
PROTECT(x = as_state_array(x)); nprotect++;
dim = INTEGER(GET_DIM(x));
nvars = dim[0]; nrepsx = dim[1];
if (ntimes != dim[2])
errorcall(R_NilValue,"in 'rmeasure': length of 'times' and 3rd dimension of 'x' do not agree");
PROTECT(params = as_matrix(params)); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nrepsp = dim[1];
nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx;
if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0))
errorcall(R_NilValue,"in 'rmeasure': larger number of replicates is not a multiple of smaller");
dim = INTEGER(GET_DIM(GET_SLOT(object,install("data"))));
nobs = dim[0];
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(GET_SLOT(object,install("data"))))); nprotect++;
// set up the covariate table
covariate_table = make_covariate_table(object,&ncovars);
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
{
int dim[3] = {nobs, nreps, ntimes};
const char *dimnm[3] = {"variable","rep","time"};
PROTECT(Y = makearray(3,dim)); nprotect++;
setrownames(Y,Onames,3);
fixdimnames(Y,dimnm,3);
}
// extract the user-defined function
PROTECT(pompfun = GET_SLOT(object,install("rmeasure"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
// first do setup
switch (mode) {
case Rfun: // use R function
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // use native routine
// construct state, parameter, covariate, observable indices
oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++;
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov
break;
}
// now do computations
switch (mode) {
case Rfun: // R function
{
int first = 1;
int use_names = 0;
double *yt = REAL(Y);
double *time = REAL(times);
double *tp = REAL(tvec);
double *cp = REAL(cvec);
double *xp = REAL(xvec);
double *pp = REAL(pvec);
double *xs = REAL(x);
double *ps = REAL(params);
double *ys;
int *posn;
int i, j, k;
for (k = 0; k < ntimes; k++, time++) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
*tp = *time; // copy the time
table_lookup(&covariate_table,*tp,cp); // interpolate the covariates
for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates
// copy the states and parameters into place
for (i = 0; i < nvars; i++) xp[i] = xs[i+nvars*((j%nrepsx)+nrepsx*k)];
for (i = 0; i < npars; i++) pp[i] = ps[i+npars*(j%nrepsp)];
if (first) {
// evaluate the call
PROTECT(ans = eval(fcall,rho)); nprotect++;
if (LENGTH(ans) != nobs) {
errorcall(R_NilValue,"in 'rmeasure': user 'rmeasure' returns a vector of %d observables but %d are expected: compare 'data' slot?",
LENGTH(ans),nobs);
}
// get name information to fix potential alignment problems
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) { // match names against names from data slot
posn = INTEGER(PROTECT(matchnames(Onames,nm,"observables"))); nprotect++;
} else {
posn = 0;
}
ys = REAL(AS_NUMERIC(ans));
first = 0;
} else {
ys = REAL(AS_NUMERIC(eval(fcall,rho)));
}
if (use_names) {
for (i = 0; i < nobs; i++) yt[posn[i]] = ys[i];
} else {
for (i = 0; i < nobs; i++) yt[i] = ys[i];
}
}
}
}
break;
case native: // native routine
{
double *yt = REAL(Y);
double *time = REAL(times);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *xp, *pp;
int j, k;
set_pomp_userdata(fcall);
GetRNGstate();
for (k = 0; k < ntimes; k++, time++) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,*time,cp);
for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates
xp = &xs[nvars*((j%nrepsx)+nrepsx*k)];
pp = &ps[npars*(j%nrepsp)];
(*ff)(yt,xp,pp,oidx,sidx,pidx,cidx,ncovars,cp,*time);
}
}
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov
break;
}
UNPROTECT(nprotect);
return Y;
}
SEXP do_dmeasure (SEXP object, SEXP y, SEXP x, SEXP times, SEXP params, SEXP log, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int give_log;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
SEXP pompfun;
SEXP cvec, tvec = R_NilValue;
SEXP xvec = R_NilValue, yvec = R_NilValue, pvec = R_NilValue;
SEXP fn, ans, fcall, rho = R_NilValue;
SEXP F;
int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0;
int *dim;
struct lookup_table covariate_table;
pomp_measure_model_density *ff = NULL;
PROTECT(times = AS_NUMERIC(times)); nprotect++;
ntimes = length(times);
if (ntimes < 1)
errorcall(R_NilValue,"in 'dmeasure': length('times') = 0, no work to do");
PROTECT(y = as_matrix(y)); nprotect++;
dim = INTEGER(GET_DIM(y));
nobs = dim[0];
if (ntimes != dim[1])
errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 2nd dimension of 'y' do not agree");
PROTECT(x = as_state_array(x)); nprotect++;
dim = INTEGER(GET_DIM(x));
nvars = dim[0]; nrepsx = dim[1];
if (ntimes != dim[2])
errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 3rd dimension of 'x' do not agree");
PROTECT(params = as_matrix(params)); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nrepsp = dim[1];
nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx;
if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0))
errorcall(R_NilValue,"in 'dmeasure': larger number of replicates is not a multiple of smaller");
PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(y))); nprotect++;
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
give_log = *(INTEGER(AS_INTEGER(log)));
// set up the covariate table
covariate_table = make_covariate_table(object,&ncovars);
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
// extract the user-defined function
PROTECT(pompfun = GET_SLOT(object,install("dmeasure"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
// first do setup
switch (mode) {
case Rfun: // R function
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(yvec = NEW_NUMERIC(nobs)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(yvec,Onames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++;
SET_TAG(fcall,install("log"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(yvec,fcall)); nprotect++;
SET_TAG(fcall,install("y"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate, observable indices
oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++;
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov
break;
}
// create array to store results
{
int dim[2] = {nreps, ntimes};
const char *dimnm[2] = {"rep","time"};
PROTECT(F = makearray(2,dim)); nprotect++;
fixdimnames(F,dimnm,2);
}
// now do computations
switch (mode) {
case Rfun: // R function
{
int first = 1;
double *ys = REAL(y);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *tp = REAL(tvec);
double *xp = REAL(xvec);
double *yp = REAL(yvec);
double *pp = REAL(pvec);
double *ft = REAL(F);
double *time = REAL(times);
int j, k;
for (k = 0; k < ntimes; k++, time++, ys += nobs) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
*tp = *time; // copy the time
table_lookup(&covariate_table,*time,cp); // interpolate the covariates
memcpy(yp,ys,nobs*sizeof(double));
for (j = 0; j < nreps; j++, ft++) { // loop over replicates
// copy the states and parameters into place
memcpy(xp,&xs[nvars*((j%nrepsx)+nrepsx*k)],nvars*sizeof(double));
memcpy(pp,&ps[npars*(j%nrepsp)],npars*sizeof(double));
if (first) {
// evaluate the call
PROTECT(ans = eval(fcall,rho)); nprotect++;
if (LENGTH(ans) != 1)
errorcall(R_NilValue,"in 'dmeasure': user 'dmeasure' returns a vector of length %d when it should return a scalar",LENGTH(ans));
*ft = *(REAL(AS_NUMERIC(ans)));
first = 0;
} else {
*ft = *(REAL(AS_NUMERIC(eval(fcall,rho))));
}
}
}
}
break;
case native: // native code
set_pomp_userdata(fcall);
{
double *yp = REAL(y);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *ft = REAL(F);
double *time = REAL(times);
double *xp, *pp;
int j, k;
for (k = 0; k < ntimes; k++, time++, yp += nobs) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,*time,cp);
for (j = 0; j < nreps; j++, ft++) { // loop over replicates
xp = &xs[nvars*((j%nrepsx)+nrepsx*k)];
pp = &ps[npars*(j%nrepsp)];
(*ff)(ft,yp,xp,pp,give_log,oidx,sidx,pidx,cidx,ncovars,cp,*time);
}
}
}
unset_pomp_userdata();
break;
default:
errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov
break;
}
UNPROTECT(nprotect);
return F;
}
SEXP attribute_hidden
do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args);
int m, zero = 0;
R_xlen_t *lengths, *counters, longest = 0;
m = length(varyingArgs);
SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
Rboolean named = vnames != R_NilValue;
lengths = (R_xlen_t *) R_alloc(m, sizeof(R_xlen_t));
for (int i = 0; i < m; i++) {
SEXP tmp1 = VECTOR_ELT(varyingArgs, i);
lengths[i] = xlength(tmp1);
if (isObject(tmp1)) { // possibly dispatch on length()
/* Cache the .Primitive: unclear caching is worthwhile. */
static SEXP length_op = NULL;
if (length_op == NULL) length_op = R_Primitive("length");
// DispatchOrEval() needs 'args' to be a pairlist
SEXP ans, tmp2 = PROTECT(list1(tmp1));
if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1))
lengths[i] = (R_xlen_t) (TYPEOF(ans) == REALSXP ?
REAL(ans)[0] : asInteger(ans));
UNPROTECT(1);
}
if (lengths[i] == 0) zero++;
if (lengths[i] > longest) longest = lengths[i];
}
if (zero && longest)
error(_("zero-length inputs cannot be mixed with those of non-zero length"));
counters = (R_xlen_t *) R_alloc(m, sizeof(R_xlen_t));
memset(counters, 0, m * sizeof(R_xlen_t));
SEXP mindex = PROTECT(allocVector(VECSXP, m));
SEXP nindex = PROTECT(allocVector(VECSXP, m));
/* build a call like
f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
*/
SEXP fcall = R_NilValue; // -Wall
if (constantArgs == R_NilValue)
;
else if (isVectorList(constantArgs))
fcall = VectorToPairList(constantArgs);
else
error(_("argument 'MoreArgs' of 'mapply' is not a list"));
PROTECT_INDEX fi;
PROTECT_WITH_INDEX(fcall, &fi);
Rboolean realIndx = longest > INT_MAX;
SEXP Dots = install("dots");
for (int j = m - 1; j >= 0; j--) {
SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j)));
SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j)));
REPROTECT(fcall = LCONS(tmp2, fcall), fi);
UNPROTECT(2);
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j)));
}
REPROTECT(fcall = LCONS(f, fcall), fi);
SEXP ans = PROTECT(allocVector(VECSXP, longest));
for (int i = 0; i < longest; i++) {
for (int j = 0; j < m; j++) {
counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
if (realIndx)
REAL(VECTOR_ELT(nindex, j))[0] = (double) counters[j];
else
INTEGER(VECTOR_ELT(nindex, j))[0] = (int) counters[j];
}
SEXP tmp = eval(fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
for (int j = 0; j < m; j++)
if (counters[j] != lengths[j])
warning(_("longer argument not a multiple of length of shorter"));
UNPROTECT(5);
return ans;
}
SEXP attribute_hidden
do_mapply(SEXP f, SEXP varyingArgs, SEXP constantArgs, SEXP rho)
{
int i, j, m, *lengths, *counters, named, longest = 0, zero = 0;
SEXP vnames, fcall = R_NilValue, mindex, nindex, tmp1, tmp2, ans;
m = length(varyingArgs);
vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
named = vnames != R_NilValue;
lengths = (int *) R_alloc(m, sizeof(int));
for(i = 0; i < m; i++){
lengths[i] = length(VECTOR_ELT(varyingArgs, i));
if(lengths[i] == 0) zero++;
if (lengths[i] > longest) longest = lengths[i];
}
if (zero && longest)
error(_("Zero-length inputs cannot be mixed with those of non-zero length"));
counters = (int *) R_alloc(m, sizeof(int));
for(i = 0; i < m; counters[i++] = 0);
mindex = PROTECT(allocVector(VECSXP, m));
nindex = PROTECT(allocVector(VECSXP, m));
/* build a call like
f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
*/
if (constantArgs == R_NilValue)
PROTECT(fcall = R_NilValue);
else if(isVectorList(constantArgs))
PROTECT(fcall = VectorToPairList(constantArgs));
else
error(_("argument 'MoreArgs' of 'mapply' is not a list"));
for(j = m - 1; j >= 0; j--) {
SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
SET_VECTOR_ELT(nindex, j, allocVector(INTSXP, 1));
PROTECT(tmp1 = lang3(R_Bracket2Symbol,
install("dots"),
VECTOR_ELT(mindex, j)));
PROTECT(tmp2 = lang3(R_Bracket2Symbol,
tmp1,
VECTOR_ELT(nindex, j)));
UNPROTECT(3);
PROTECT(fcall = LCONS(tmp2, fcall));
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, install(translateChar(STRING_ELT(vnames, j))));
}
UNPROTECT(1);
PROTECT(fcall = LCONS(f, fcall));
PROTECT(ans = allocVector(VECSXP, longest));
for(i = 0; i < longest; i++) {
for(j = 0; j < m; j++) {
counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
INTEGER(VECTOR_ELT(nindex, j))[0] = counters[j];
}
SET_VECTOR_ELT(ans, i, eval(fcall, rho));
}
for(j = 0; j < m; j++) {
if (counters[j] != lengths[j])
warning(_("longer argument not a multiple of length of shorter"));
}
UNPROTECT(5);
return(ans);
}
SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int npars, nreps;
SEXP Pnames, F, fn, fcall;
SEXP pompfun;
int *dim;
PROTECT(params = as_matrix(params)); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nreps = dim[1];
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
// extract the user-defined function
PROTECT(pompfun = GET_SLOT(object,install("dprior"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
// to store results
PROTECT(F = NEW_NUMERIC(nreps)); nprotect++;
// first do setup
switch (mode) {
case Rfun: // use R function
{
SEXP pvec, rho;
double *pp, *ps, *pt;
int j;
// temporary storage
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++;
SET_TAG(fcall,install("log"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
pp = REAL(pvec);
for (j = 0, ps = REAL(params), pt = REAL(F); j < nreps; j++, ps += npars, pt++) {
memcpy(pp,ps,npars*sizeof(double));
*pt = *(REAL(AS_NUMERIC(eval(fcall,rho))));
}
}
break;
case native: // use native routine
{
int give_log, *pidx = 0;
pomp_dprior *ff = NULL;
double *ps, *pt;
int j;
// construct state, parameter, covariate, observable indices
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames"))); nprotect++;
// address of native routine
ff = (pomp_dprior *) R_ExternalPtrAddr(fn);
give_log = *(INTEGER(AS_INTEGER(log)));
R_CheckUserInterrupt(); // check for user interrupt
set_pomp_userdata(fcall);
// loop over replicates
for (j = 0, pt = REAL(F), ps = REAL(params); j < nreps; j++, ps += npars, pt++)
(*ff)(pt,ps,give_log,pidx);
unset_pomp_userdata();
}
break;
default:
error("unrecognized 'mode' slot in 'dprior'");
break;
}
UNPROTECT(nprotect);
return F;
}