static int get_trait(SEXP variable, struct design *s, struct design *r, struct variable *v)
{
SEXP dim, cn, dn, nm;
int j, n, p;
double *xt, *x;
size_t dims[VAR_RANK_MAX];
size_t rank;
dim = GET_DIM(variable);
n = INTEGER(dim)[0];
p = INTEGER(dim)[1];
xt = NUMERIC_POINTER(variable);
x = (void *)R_alloc(n * p, sizeof(*x));
if (p == 0)
DOMAIN_ERROR("variable dimensions must be nonzero");
if (n > 0)
matrix_dtrans(n, p, xt, n, x, p);
if (p == 1) {
rank = 0;
} else {
rank = 1;
dims[0] = (size_t)p;
}
if (inherits(variable, "send")) {
if (n != design_count(s))
DOMAIN_ERROR("variable dimension must match sender count");
v->design = VARIABLE_DESIGN_SEND;
v->var.send = design_add_trait(s, NULL, x, dims, rank);
} else {
if (n != design_count(r))
DOMAIN_ERROR("variable dimension must match receiver count");
v->design = VARIABLE_DESIGN_RECV;
v->var.recv = design_add_trait(r, NULL, x, dims, rank);
}
v->type = VARIABLE_TYPE_TRAIT;
dn = GET_DIMNAMES(variable);
cn = GET_COLNAMES(dn);
v->names = (void *)R_alloc(p, sizeof(*v->names));
for (j = 0; j < p; j++) {
nm = STRING_ELT(cn, j);
v->names[j] = CHAR(nm);
}
return 0;
}
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;
}
static int get_terms(SEXP factors, const struct variables *v,
struct design *s, struct design *r, struct design2 *d,
struct terms *tm)
{
SEXP dim, dimnames, colnames;
int j, m, n, *xfactors;
size_t *ind, order;
int err = 0;
const char *name;
if (!IS_INTEGER(factors))
DOMAIN_ERROR("'factors' should be integer");
if (!(isMatrix(factors) || LENGTH(factors) == 0))
DOMAIN_ERROR("'factors' should be a matrix or an empty integer vector");
/* validate factor matrix */
if (isMatrix(factors)) {
dim = GET_DIM(factors);
m = INTEGER(dim)[0];
n = INTEGER(dim)[1];
xfactors = INTEGER_POINTER(factors);
if ((size_t)m != v->count)
DOMAIN_ERROR("'factors' should have"
" rows equal to the number of variables");
dimnames = GET_DIMNAMES(factors);
colnames = GET_COLNAMES(dimnames);
} else {
m = 0;
n = 0;
xfactors = NULL;
}
ind = (void *)R_alloc(v->count, sizeof(*ind));
tm->item = (void *)R_alloc(n, sizeof(*tm->item));
tm->count = n;
for (j = 0; j < n; j++) {
name = CHAR(STRING_ELT(colnames, j));
err = get_term_factors(name, xfactors, v, j, ind, &order);
if (err < 0)
goto out;
if (order == 0) {
DOMAIN_ERROR("intercepts are not allowed");
} else if (order == 1) {
memcpy(&tm->item[j], &v->item[ind[0]],
sizeof(struct variable));
} else if (order == 2) {
err = get_product(name,
v->item + ind[0], v->item + ind[1],
s, r, d, tm->item + j);
if (err < 0)
goto out;
} else {
DOMAIN_ERROR("interactions of order >= 3 are not implemented yet");
}
}
out:
return err;
}
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;
}
// examines weights for filtering failure
// computes log likelihood and effective sample size
// computes (if desired) prediction mean, prediction variance, filtering mean.
// it is assumed that ncol(x) == ncol(params).
// weights are used in filtering mean computation.
// if length(weights) == 1, an unweighted average is computed.
// returns all of the above in a named list
SEXP pfilter2_computations (SEXP x, SEXP params, SEXP Np,
SEXP rw, SEXP rw_sd,
SEXP predmean, SEXP predvar,
SEXP filtmean, SEXP onepar,
SEXP weights, SEXP tol)
{
int nprotect = 0;
SEXP pm = R_NilValue, pv = R_NilValue, fm = R_NilValue;
SEXP rw_names, ess, fail, loglik;
SEXP newstates = R_NilValue, newparams = R_NilValue;
SEXP retval, retvalnames;
double *xpm = 0, *xpv = 0, *xfm = 0, *xw = 0, *xx = 0, *xp = 0, *xpw=0;
int *xpa=0;
SEXP dimX, dimP, newdim, Xnames, Pnames, pindex;
SEXP pw=R_NilValue,pa=R_NilValue, psample=R_NilValue;
int *dim, *pidx, lv, np;
int nvars, npars = 0, nrw = 0, nreps, offset, nlost;
int do_rw, do_pm, do_pv, do_fm, do_par_resamp, all_fail = 0;
double sum, sumsq, vsq, ws, w, toler;
int j, k;
PROTECT(dimX = GET_DIM(x)); nprotect++;
dim = INTEGER(dimX);
nvars = dim[0]; nreps = dim[1];
xx = REAL(x);
PROTECT(Xnames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(dimP = GET_DIM(params)); nprotect++;
dim = INTEGER(dimP);
npars = dim[0];
if (nreps != dim[1])
error("'states' and 'params' do not agree in second dimension");
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
np = INTEGER(AS_INTEGER(Np))[0]; // number of particles to resample
PROTECT(rw_names = GET_NAMES(rw_sd)); nprotect++; // names of parameters undergoing random walk
do_rw = *(LOGICAL(AS_LOGICAL(rw))); // do random walk in parameters?
do_pm = *(LOGICAL(AS_LOGICAL(predmean))); // calculate prediction means?
do_pv = *(LOGICAL(AS_LOGICAL(predvar))); // calculate prediction variances?
do_fm = *(LOGICAL(AS_LOGICAL(filtmean))); // calculate filtering means?
do_par_resamp = *(LOGICAL(AS_LOGICAL(onepar))); // are all cols of 'params' the same?
do_par_resamp = !do_par_resamp || do_rw || (np != nreps); // should we do parameter resampling?
PROTECT(ess = NEW_NUMERIC(1)); nprotect++; // effective sample size
PROTECT(loglik = NEW_NUMERIC(1)); nprotect++; // log likelihood
PROTECT(fail = NEW_LOGICAL(1)); nprotect++; // particle failure?
xw = REAL(weights);
toler = *(REAL(tol)); // failure tolerance
// check the weights and compute sum and sum of squares
for (k = 0, w = 0, ws = 0, nlost = 0; k < nreps; k++) {
if (xw[k] >= 0) {
w += xw[k];
ws += xw[k]*xw[k];
} else { // this particle is lost
xw[k] = 0;
nlost++;
}
}
if (nlost >= nreps) all_fail = 1; // all particles are lost
if (all_fail) {
*(REAL(loglik)) = log(toler); // minimum log-likelihood
*(REAL(ess)) = 0; // zero effective sample size
} else {
*(REAL(loglik)) = log(w/((double) nreps)); // mean of weights is likelihood
*(REAL(ess)) = w*w/ws; // effective sample size
}
*(LOGICAL(fail)) = all_fail;
if (do_rw) {
// indices of parameters undergoing random walk
PROTECT(pindex = matchnames(Pnames,rw_names,"parameters")); nprotect++;
xp = REAL(params);
pidx = INTEGER(pindex);
nrw = LENGTH(rw_names);
lv = nvars+nrw;
} else {
pidx = NULL;
lv = nvars;
}
if (do_pm || do_pv) {
PROTECT(pm = NEW_NUMERIC(lv)); nprotect++;
xpm = REAL(pm);
}
if (do_pv) {
PROTECT(pv = NEW_NUMERIC(lv)); nprotect++;
xpv = REAL(pv);
}
if (do_fm) {
if (do_rw) {
PROTECT(fm = NEW_NUMERIC(nvars+npars)); nprotect++;
} else {
PROTECT(fm = NEW_NUMERIC(nvars)); nprotect++;
}
xfm = REAL(fm);
}
PROTECT(pa = NEW_INTEGER(np)); nprotect++;
xpa = INTEGER(pa);
for (j = 0; j < nvars; j++) { // state variables
// compute prediction mean
if (do_pm || do_pv) {
for (k = 0, sum = 0; k < nreps; k++) sum += xx[j+k*nvars];
sum /= ((double) nreps);
xpm[j] = sum;
}
// compute prediction variance
if (do_pv) {
for (k = 0, sumsq = 0; k < nreps; k++) {
vsq = xx[j+k*nvars]-sum;
sumsq += vsq*vsq;
}
xpv[j] = sumsq / ((double) (nreps - 1));
}
// compute filter mean
if (do_fm) {
if (all_fail) { // unweighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars];
xfm[j] = ws/((double) nreps);
} else { // weighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars]*xw[k];
xfm[j] = ws/w;
}
}
}
// compute means and variances for parameters (if needed)
if (do_rw) {
for (j = 0; j < nrw; j++) {
offset = pidx[j]; // position of the parameter
if (do_pm || do_pv) {
for (k = 0, sum = 0; k < nreps; k++) sum += xp[offset+k*npars];
sum /= ((double) nreps);
xpm[nvars+j] = sum;
}
if (do_pv) {
for (k = 0, sumsq = 0; k < nreps; k++) {
vsq = xp[offset+k*npars]-sum;
sumsq += vsq*vsq;
}
xpv[nvars+j] = sumsq / ((double) (nreps - 1));
}
}
if (do_fm) {
for (j = 0; j < npars; j++) {
if (all_fail) { // unweighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars];
xfm[nvars+j] = ws/((double) nreps);
} else { // weighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars]*xw[k];
xfm[nvars+j] = ws/w;
}
}
}
}
GetRNGstate();
if (!all_fail) { // resample the particles unless we have filtering failure
int xdim[2];
//int sample[np];
double *ss = 0, *st = 0, *ps = 0, *pt = 0;
// create storage for new states
xdim[0] = nvars; xdim[1] = np;
PROTECT(newstates = makearray(2,xdim)); nprotect++;
setrownames(newstates,Xnames,2);
ss = REAL(x);
st = REAL(newstates);
// create storage for new parameters
if (do_par_resamp) {
xdim[0] = npars; xdim[1] = np;
PROTECT(newparams = makearray(2,xdim)); nprotect++;
setrownames(newparams,Pnames,2);
ps = REAL(params);
pt = REAL(newparams);
}
PROTECT(pw = NEW_NUMERIC(nreps)); nprotect++;
xpw = REAL(pw);
for (k = 0; k < nreps; k++)
xpw[k]=REAL(weights)[k];
nosort_resamp(nreps,REAL(weights),np,xpa,0);
for (k = 0; k < np; k++) { // copy the particles
for (j = 0, xx = ss+nvars*xpa[k]; j < nvars; j++, st++, xx++)
*st = *xx;
if (do_par_resamp) {
for (j = 0, xp = ps+npars*xpa[k]; j < npars; j++, pt++, xp++){
*pt = *xp;
}
}
}
} else { // don't resample: just drop 3rd dimension in x prior to return
PROTECT(newdim = NEW_INTEGER(2)); nprotect++;
dim = INTEGER(newdim);
dim[0] = nvars; dim[1] = nreps;
SET_DIM(x,newdim);
setrownames(x,Xnames,2);
}
if (do_rw) { // if random walk, adjust prediction variance and move particles
xx = REAL(rw_sd);
xp = (all_fail || !do_par_resamp) ? REAL(params) : REAL(newparams);
nreps = (all_fail) ? nreps : np;
for (j = 0; j < nrw; j++) {
offset = pidx[j];
vsq = xx[j];
if (do_pv) {
xpv[nvars+j] += vsq*vsq;
}
for (k = 0; k < nreps; k++)
xp[offset+k*npars] += rnorm(0,vsq);
}
}
renormalize(xpw,nreps,0);
PutRNGstate();
PROTECT(retval = NEW_LIST(10)); nprotect++;
PROTECT(retvalnames = NEW_CHARACTER(10)); nprotect++;
SET_STRING_ELT(retvalnames,0,mkChar("fail"));
SET_STRING_ELT(retvalnames,1,mkChar("loglik"));
SET_STRING_ELT(retvalnames,2,mkChar("ess"));
SET_STRING_ELT(retvalnames,3,mkChar("states"));
SET_STRING_ELT(retvalnames,4,mkChar("params"));
SET_STRING_ELT(retvalnames,5,mkChar("pm"));
SET_STRING_ELT(retvalnames,6,mkChar("pv"));
SET_STRING_ELT(retvalnames,7,mkChar("fm"));
SET_STRING_ELT(retvalnames,8,mkChar("weight"));
SET_STRING_ELT(retvalnames,9,mkChar("pa"));
SET_NAMES(retval,retvalnames);
SET_ELEMENT(retval,0,fail);
SET_ELEMENT(retval,1,loglik);
SET_ELEMENT(retval,2,ess);
if (all_fail) {
SET_ELEMENT(retval,3,x);
} else {
SET_ELEMENT(retval,3,newstates);
}
if (all_fail || !do_par_resamp) {
SET_ELEMENT(retval,4,params);
} else {
SET_ELEMENT(retval,4,newparams);
}
if (do_pm) {
SET_ELEMENT(retval,5,pm);
}
if (do_pv) {
SET_ELEMENT(retval,6,pv);
}
if (do_fm) {
SET_ELEMENT(retval,7,fm);
}
SET_ELEMENT(retval,8,pw);
SET_ELEMENT(retval,9,pa);
UNPROTECT(nprotect);
return(retval);
}
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_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 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_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;
}
void FLQuant_pointer::Init(SEXP x)
{
SEXP Quant = GET_SLOT(x, install(".Data")),
dims = GET_DIM(Quant),
dimnames = GET_DIMNAMES(Quant);
data = NUMERIC_POINTER(AS_NUMERIC(Quant));
int dim[6], n = length(dims);
dim[0] = INTEGER(dims)[0];
dim[1] = INTEGER(dims)[1];
dim[2] = INTEGER(dims)[2];
dim[3] = INTEGER(dims)[3];
dim[4] = INTEGER(dims)[4];
dim[5] = n>=6 ? INTEGER(dims)[5] : 1;
if (((int)dim[0]) < 1 || ((int)dim[1]) < 1 ||
((int)dim[2]) < 1 || ((int)dim[3]) < 1 || ((int)dim[4]) < 1 || ((int)dim[5]) < 1)
{
UNPROTECT(1);
return;
}
minquant() = 0;
minyr() = 0;
maxquant() = (int)dim[0] -1;
maxyr() = (int)dim[1] -1;
nunits() = (int)dim[2];
nseasons() = (int)dim[3];
nareas() = (int)dim[4];
niters() = (int)dim[5];
if (dimnames != R_NilValue)
if (TYPEOF(dimnames) == VECSXP)
{
int t = 0;
const char *c;
if (n >= 1 && INTEGER(dims)[0] >= 1)
{
c = CHAR(STRING_ELT(VECTOR_ELT(dimnames, 0), 0));
//check that name is not a text string
for (int i=0; i<=(signed)strlen(c); i++)
if (isalpha(c[i])) t=1;
if (t !=1)
t = atoi(c);
minquant() += t;
maxquant() += t;
}
if (n >= 2 && INTEGER(dims)[1] >= 1)
{
t = 0;
c = CHAR(STRING_ELT(VECTOR_ELT(dimnames, 1), 0));
//check that name is not a text string
for (int i=0; i<=(signed)strlen(c); i++)
if (isalpha(c[i])) t=1;
if (t !=1)
t = atoi(c);
minyr() += t;
maxyr() += t;
}
}
InitFlag() = true;
UNPROTECT(1);
}
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;
}
