SEXP do_substitute_direct(SEXP f, SEXP env)
{
SEXP s;
if (TYPEOF(env) == VECSXP)
env = NewEnvironment(R_NilValue, VectorToPairList(env), R_NilValue);
else if (TYPEOF(env) == LISTSXP)
env = NewEnvironment(R_NilValue, duplicate(env), R_NilValue);
if(TYPEOF(env) != ENVSXP)
error(_("invalid list for substitution"));
PROTECT(env);
PROTECT(f);
s = substitute(f, env);
UNPROTECT(2);
return(s);
}
SEXP exprToFunction(int nVariables, const char **vaList, SEXP rExpr) {
PROTECT(rExpr);
SEXP charList, rChar, pl;
SEXP rFunc;
PROTECT(rFunc= allocSExp(CLOSXP));
SET_CLOENV(rFunc, R_GlobalEnv);
int i = 0, warn= 0, n= 0;
if(nVariables > 0) {
PROTECT(charList = allocVector(STRSXP, nVariables));
for(int i=0; i < nVariables; i++){ //TODO STRSXP fill
PROTECT(rChar= mkChar(vaList[i]));
SET_STRING_ELT(charList, i, rChar);
UNPROTECT(1);
}
PROTECT(charList= VectorToPairList(charList));
n= length(charList);
if(n > 0) {
PROTECT(pl = allocList(n));
if(n == 1) {
SET_TAG(pl, CreateTag(CAR(charList)));
SETCAR(pl, R_MissingArg);
}
else
{ SET_TAG(pl, CreateTag(CAR(charList)));
SETCAR(pl, R_MissingArg);
SEXP nextpl= CDR(pl);
SEXP nextChar= CDR(charList);
for (i= 1; i < n; i++, nextpl = CDR(nextpl), nextChar = CDR(nextChar)) {
SET_TAG(nextpl, CreateTag(CAR(nextChar)));
SETCAR(nextpl, R_MissingArg);
}
}
} }
SET_FORMALS(rFunc, pl);
SET_BODY(rFunc, rExpr);
//setAttrib(rFunc, R_SourceSymbol, eval(lang2(install("deparse"), rFunc), R_BaseEnv)); // TODO: Deparse not necessary
if(n > 0) {UNPROTECT(1);}
UNPROTECT(4);
return rFunc;
}
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_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 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 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 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;
}
}
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;
}
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;
}
