SEXP do_rmeasure (SEXP object, SEXP x, SEXP times, SEXP params, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs; SEXP Snames, Pnames, Cnames, Onames; SEXP cvec, tvec = R_NilValue, xvec = R_NilValue, pvec = R_NilValue; SEXP fn, fcall, rho = R_NilValue, ans, nm; SEXP pompfun; SEXP Y; int *dim; int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0; struct lookup_table covariate_table; pomp_measure_model_simulator *ff = NULL; PROTECT(times = AS_NUMERIC(times)); nprotect++; ntimes = length(times); if (ntimes < 1) errorcall(R_NilValue,"in 'rmeasure': length('times') = 0, no work to do"); PROTECT(x = as_state_array(x)); nprotect++; dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nrepsx = dim[1]; if (ntimes != dim[2]) errorcall(R_NilValue,"in 'rmeasure': length of 'times' and 3rd dimension of 'x' do not agree"); PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nrepsp = dim[1]; nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx; if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0)) errorcall(R_NilValue,"in 'rmeasure': larger number of replicates is not a multiple of smaller"); dim = INTEGER(GET_DIM(GET_SLOT(object,install("data")))); nobs = dim[0]; PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++; PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(GET_SLOT(object,install("data"))))); nprotect++; // set up the covariate table covariate_table = make_covariate_table(object,&ncovars); // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); { int dim[3] = {nobs, nreps, ntimes}; const char *dimnm[3] = {"variable","rep","time"}; PROTECT(Y = makearray(3,dim)); nprotect++; setrownames(Y,Onames,3); fixdimnames(Y,dimnm,3); } // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("rmeasure"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // first do setup switch (mode) { case Rfun: // use R function PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,fcall)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // use native routine // construct state, parameter, covariate, observable indices oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++; sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++; pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++; cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++; // address of native routine *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov break; } // now do computations switch (mode) { case Rfun: // R function { int first = 1; int use_names = 0; double *yt = REAL(Y); double *time = REAL(times); double *tp = REAL(tvec); double *cp = REAL(cvec); double *xp = REAL(xvec); double *pp = REAL(pvec); double *xs = REAL(x); double *ps = REAL(params); double *ys; int *posn; int i, j, k; for (k = 0; k < ntimes; k++, time++) { // loop over times R_CheckUserInterrupt(); // check for user interrupt *tp = *time; // copy the time table_lookup(&covariate_table,*tp,cp); // interpolate the covariates for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates // copy the states and parameters into place for (i = 0; i < nvars; i++) xp[i] = xs[i+nvars*((j%nrepsx)+nrepsx*k)]; for (i = 0; i < npars; i++) pp[i] = ps[i+npars*(j%nrepsp)]; if (first) { // evaluate the call PROTECT(ans = eval(fcall,rho)); nprotect++; if (LENGTH(ans) != nobs) { errorcall(R_NilValue,"in 'rmeasure': user 'rmeasure' returns a vector of %d observables but %d are expected: compare 'data' slot?", LENGTH(ans),nobs); } // get name information to fix potential alignment problems PROTECT(nm = GET_NAMES(ans)); nprotect++; use_names = !isNull(nm); if (use_names) { // match names against names from data slot posn = INTEGER(PROTECT(matchnames(Onames,nm,"observables"))); nprotect++; } else { posn = 0; } ys = REAL(AS_NUMERIC(ans)); first = 0; } else { ys = REAL(AS_NUMERIC(eval(fcall,rho))); } if (use_names) { for (i = 0; i < nobs; i++) yt[posn[i]] = ys[i]; } else { for (i = 0; i < nobs; i++) yt[i] = ys[i]; } } } } break; case native: // native routine { double *yt = REAL(Y); double *time = REAL(times); double *xs = REAL(x); double *ps = REAL(params); double *cp = REAL(cvec); double *xp, *pp; int j, k; set_pomp_userdata(fcall); GetRNGstate(); for (k = 0; k < ntimes; k++, time++) { // loop over times R_CheckUserInterrupt(); // check for user interrupt // interpolate the covar functions for the covariates table_lookup(&covariate_table,*time,cp); for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates xp = &xs[nvars*((j%nrepsx)+nrepsx*k)]; pp = &ps[npars*(j%nrepsp)]; (*ff)(yt,xp,pp,oidx,sidx,pidx,cidx,ncovars,cp,*time); } } PutRNGstate(); unset_pomp_userdata(); } break; default: errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov break; } UNPROTECT(nprotect); return Y; }
SEXP do_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_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_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; }