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