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; }
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; }