pomp
Inference for partially observed Markov processes
•All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Macros Pages
Macros | Functions | Variables
trajectory.c File Reference
#include <Rdefines.h>
#include "internal.h"
Include dependency graph for trajectory.c:

Go to the source code of this file.

Macros

#define COMMON(X)   (_pomp_vf_eval_block.common.X)
 
#define RFUN(X)   (_pomp_vf_eval_block.shared.R_fun.X)
 
#define NAT(X)   (_pomp_vf_eval_block.shared.native_code.X)
 

Functions

static R_INLINE SEXP ret_array (int nvars, int nreps, int ntimes, SEXP Snames, SEXP repnames)
 
SEXP iterate_map (SEXP object, SEXP times, SEXP t0, SEXP x0, SEXP params, SEXP gnsi)
 
SEXP pomp_desolve_setup (SEXP object, SEXP x0, SEXP params, SEXP gnsi)
 
void pomp_vf_eval (int *neq, double *t, double *y, double *ydot, double *yout, int *ip)
 
SEXP pomp_desolve_takedown (void)
 

Variables

struct { 
 
   struct { 
 
      pompfunmode   mode 
 
      SEXP   object 
 
      SEXP   params 
 
      SEXP   cov 
 
      lookup_table_t   covar_table 
 
      int   nvars 
 
      int   npars 
 
      int   ncovars 
 
      int   nreps 
 
   }   common 
 
   union { 
 
      struct { 
 
         SEXP   fn 
 
         SEXP   args 
 
         SEXP   Snames 
 
      }   R_fun 
 
      struct { 
 
         SEXP   args 
 
         SEXP   sindex 
 
         SEXP   pindex 
 
         SEXP   cindex 
 
         pomp_skeleton *   fun 
 
      }   native_code 
 
   }   shared 
 
} _pomp_vf_eval_block 
 

Macro Definition Documentation

◆ COMMON

#define COMMON (   X)    (_pomp_vf_eval_block.common.X)

Definition at line 152 of file trajectory.c.

◆ NAT

#define NAT (   X)    (_pomp_vf_eval_block.shared.native_code.X)

Definition at line 154 of file trajectory.c.

◆ RFUN

#define RFUN (   X)    (_pomp_vf_eval_block.shared.R_fun.X)

Definition at line 153 of file trajectory.c.

Function Documentation

◆ iterate_map()

SEXP iterate_map ( SEXP  object,
SEXP  times,
SEXP  t0,
SEXP  x0,
SEXP  params,
SEXP  gnsi 
)

Definition at line 19 of file trajectory.c.

20{
21
22 pompfunmode mode = undef;
23 SEXP fn, args;
24 SEXP X, cov;
25 SEXP Snames, Pnames, Cnames;
26 SEXP skel, pompfun;
27 SEXP accumvars;
28 SEXP repnames;
29 int *zidx = 0;
30 int nvars, npars, nreps, nrepp, ntimes, ncovars, nzeros;
31 int *dim;
32 lookup_table_t covariate_table;
33 double deltat, t;
34
35 PROTECT(skel = GET_SLOT(object,install("skeleton")));
36 deltat = *(REAL(GET_SLOT(skel,install("delta.t"))));
37 t = *(REAL(AS_NUMERIC(t0)));
38
39 PROTECT(x0 = duplicate(x0));
40 PROTECT(x0 = as_matrix(x0));
41 dim = INTEGER(GET_DIM(x0));
42 nvars = dim[0]; nreps = dim[1];
43
44 PROTECT(params = as_matrix(params));
45 dim = INTEGER(GET_DIM(params));
46 npars = dim[0]; nrepp = dim[1];
47 PROTECT(repnames = GET_COLNAMES(GET_DIMNAMES(params)));
48
49 PROTECT(times = AS_NUMERIC(times));
50 ntimes = LENGTH(times);
51
52 PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x0)));
53 PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params)));
54 PROTECT(Cnames = get_covariate_names(GET_SLOT(object,install("covar"))));
55
56 // set up the covariate table
57 covariate_table = make_covariate_table(GET_SLOT(object,install("covar")),&ncovars);
58 PROTECT(cov = NEW_NUMERIC(ncovars));
59
60 // extract user-defined function
61 PROTECT(pompfun = GET_SLOT(skel,install("skel.fn")));
62 PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode,Snames,Pnames,NA_STRING,Cnames));
63
64 // extract 'userdata' as pairlist
65 PROTECT(args = GET_SLOT(object,install("userdata")));
66
67 // create array to store results
68 PROTECT(X = ret_array(nvars,nreps,ntimes,Snames,repnames));
69
70 // get names and indices of accumulator variables
71 PROTECT(accumvars = GET_SLOT(object,install("accumvars")));
72 nzeros = LENGTH(accumvars);
73
74 int nprotect = 15;
75
76 if (nzeros > 0) {
77 zidx = INTEGER(PROTECT(matchnames(Snames,accumvars,"state variables"))); nprotect++;
78 }
79
80 // set up the computations
81 switch (mode) {
82
83 case Rfun: {
84
85 PROTECT(args = add_skel_args(args,Snames,Pnames,Cnames)); nprotect++;
86
87 iterate_skeleton_R(REAL(X),t,deltat,REAL(times),REAL(x0),REAL(params),
88 fn,args,Snames,nvars,npars,ncovars,ntimes,nrepp,nreps,nzeros,
89 &covariate_table,zidx,REAL(cov));
90
91 }
92
93 break;
94
95 case native: case regNative: {
96 int *sidx, *pidx, *cidx;
97 pomp_skeleton *ff;
98
99 *((void **) (&ff)) = R_ExternalPtrAddr(fn);
100
101 // construct state, parameter, covariate indices
102 sidx = INTEGER(GET_SLOT(pompfun,install("stateindex")));
103 pidx = INTEGER(GET_SLOT(pompfun,install("paramindex")));
104 cidx = INTEGER(GET_SLOT(pompfun,install("covarindex")));
105
106 iterate_skeleton_native(REAL(X),t,deltat,REAL(times),REAL(x0),REAL(params),
107 nvars,npars,ncovars,ntimes,nrepp,nreps,nzeros,sidx,pidx,cidx,
108 &covariate_table,zidx,ff,args,REAL(cov));
109
110 }
111
112 break;
113
114 default: // #nocov
115
116 break; // #nocov
117
118 }
119
120 UNPROTECT(nprotect);
121 return X;
122}
make_covariate_table
lookup_table_t make_covariate_table(SEXP, int *)
Definition lookup_table.c:11
add_skel_args
SEXP add_skel_args(SEXP, SEXP, SEXP, SEXP)
Definition skeleton.c:10
pomp_fun_handler
SEXP pomp_fun_handler(SEXP, SEXP, pompfunmode *, SEXP, SEXP, SEXP, SEXP)
Definition pomp_fun.c:30
iterate_skeleton_R
void iterate_skeleton_R(double *, double, double, double *, double *, double *, SEXP, SEXP, SEXP, int, int, int, int, int, int, int, lookup_table_t *, int *, double *)
Definition skeleton.c:161
iterate_skeleton_native
void iterate_skeleton_native(double *, double, double, double *, double *, double *, int, int, int, int, int, int, int, int *, int *, int *, lookup_table_t *, int *, pomp_skeleton *, SEXP, double *)
Definition skeleton.c:274
get_covariate_names
SEXP get_covariate_names(SEXP)
Definition lookup_table.c:7
X
#define X
Definition gompertz.c:14
pomp_skeleton
void pomp_skeleton(double *f, const double *x, const double *p, const int *stateindex, const int *parindex, const int *covindex, const double *covars, double t)
Definition pomp.h:73
matchnames
static R_INLINE SEXP matchnames(SEXP provided, SEXP needed, const char *where)
Definition pomp_defines.h:60
pompfunmode
pompfunmode
Definition pomp_defines.h:16
Rfun
@ Rfun
Definition pomp_defines.h:16
native
@ native
Definition pomp_defines.h:16
undef
@ undef
Definition pomp_defines.h:16
regNative
@ regNative
Definition pomp_defines.h:16
as_matrix
static R_INLINE SEXP as_matrix(SEXP x)
Definition pomp_defines.h:145
lookup_table_t
Definition pomp_defines.h:20
npars
int npars
Definition trajectory.c:132
ret_array
static R_INLINE SEXP ret_array(int nvars, int nreps, int ntimes, SEXP Snames, SEXP repnames)
Definition trajectory.c:6
Snames
SEXP Snames
Definition trajectory.c:140
ncovars
int ncovars
Definition trajectory.c:133
params
SEXP params
Definition trajectory.c:128
mode
pompfunmode mode
Definition trajectory.c:126
nreps
int nreps
Definition trajectory.c:134
args
SEXP args
Definition trajectory.c:139
cov
SEXP cov
Definition trajectory.c:129
fn
SEXP fn
Definition trajectory.c:138
nvars
int nvars
Definition trajectory.c:131
Here is the call graph for this function:

◆ pomp_desolve_setup()

SEXP pomp_desolve_setup ( SEXP  object,
SEXP  x0,
SEXP  params,
SEXP  gnsi 
)

Definition at line 156 of file trajectory.c.

156 {
157
158 pompfunmode mode = undef;
159 SEXP fn, args;
160 SEXP Snames, Pnames, Cnames;
161 SEXP pompfun, ob;
162 int *dim;
163 int nvars, npars, nreps, ncovars;
164
165 // extract user-defined skeleton function
166 PROTECT(ob = GET_SLOT(object,install("skeleton")));
167 PROTECT(pompfun = GET_SLOT(ob,install("skel.fn")));
168 // extract 'userdata' as pairlist
169 PROTECT(args = GET_SLOT(object,install("userdata")));
170
171 COMMON(object) = object;
172 COMMON(params) = params;
173 if (!isNull(COMMON(object))) R_ReleaseObject(COMMON(object));
174 if (!isNull(COMMON(params))) R_ReleaseObject(COMMON(params));
175 R_PreserveObject(COMMON(object));
176 R_PreserveObject(COMMON(params));
177
178 dim = INTEGER(GET_DIM(x0));
179 nvars = dim[0];
180 COMMON(nvars) = nvars;
181
182 dim = INTEGER(GET_DIM(params));
183 npars = dim[0]; nreps = dim[1];
184 COMMON(npars) = npars;
185 COMMON(nreps) = nreps;
186
187 // set up the covariate table
188 COMMON(covar_table) = make_covariate_table(GET_SLOT(object,install("covar")),&ncovars);
189 COMMON(ncovars) = ncovars;
190 PROTECT(COMMON(cov) = NEW_NUMERIC(ncovars));
191 R_PreserveObject(COMMON(cov));
192
193 PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x0)));
194 PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params)));
195 PROTECT(Cnames = get_covariate_names(GET_SLOT(object,install("covar"))));
196
197 PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode,Snames,Pnames,NA_STRING,Cnames));
198
199 COMMON(mode) = mode;
200
201 int nprotect = 8;
202
203 switch (COMMON(mode)) {
204
205 case Rfun: {
206
207 PROTECT(RFUN(fn) = fn);
208 PROTECT(RFUN(args) = add_skel_args(args,Snames,Pnames,Cnames));
209 PROTECT(RFUN(Snames) = Snames);
210 nprotect += 3;
211
212 if (!isNull(RFUN(fn))) R_ReleaseObject(RFUN(fn));
213 if (!isNull(RFUN(args))) R_ReleaseObject(RFUN(args));
214 if (!isNull(RFUN(Snames))) R_ReleaseObject(RFUN(Snames));
215
216 R_PreserveObject(RFUN(fn));
217 R_PreserveObject(RFUN(args));
218 R_PreserveObject(RFUN(Snames));
219
220 }
221
222 break;
223
224 case native: case regNative: {
225
226 NAT(args) = args;
227
228 PROTECT(NAT(sindex) = GET_SLOT(pompfun,install("stateindex")));
229 PROTECT(NAT(pindex) = GET_SLOT(pompfun,install("paramindex")));
230 PROTECT(NAT(cindex) = GET_SLOT(pompfun,install("covarindex")));
231 nprotect += 3;
232
233 *((void **) (&(NAT(fun)))) = R_ExternalPtrAddr(fn);
234
235 if (!isNull(NAT(args))) R_ReleaseObject(NAT(args));
236 if (!isNull(NAT(sindex))) R_ReleaseObject(NAT(sindex));
237 if (!isNull(NAT(pindex))) R_ReleaseObject(NAT(pindex));
238 if (!isNull(NAT(cindex))) R_ReleaseObject(NAT(cindex));
239
240 R_PreserveObject(NAT(args));
241 R_PreserveObject(NAT(sindex));
242 R_PreserveObject(NAT(pindex));
243 R_PreserveObject(NAT(cindex));
244
245 }
246
247 break;
248
249 default: // #nocov
250
251 err("in 'pomp_desolve_setup': unrecognized 'mode'"); // # nocov
252
253 }
254
255 UNPROTECT(nprotect);
256
257 return R_NilValue;
258}
err
#define err(...)
Definition pomp.h:21
RFUN
#define RFUN(X)
Definition trajectory.c:153
covar_table
lookup_table_t covar_table
Definition trajectory.c:130
COMMON
#define COMMON(X)
Definition trajectory.c:152
cindex
SEXP cindex
Definition trajectory.c:146
fun
pomp_skeleton * fun
Definition trajectory.c:147
sindex
SEXP sindex
Definition trajectory.c:144
pindex
SEXP pindex
Definition trajectory.c:145
NAT
#define NAT(X)
Definition trajectory.c:154
object
SEXP object
Definition trajectory.c:127
Here is the call graph for this function:

◆ pomp_desolve_takedown()

SEXP pomp_desolve_takedown ( void  )

Definition at line 292 of file trajectory.c.

292 {
293 R_ReleaseObject(COMMON(object));
294 R_ReleaseObject(COMMON(params));
295 R_ReleaseObject(COMMON(cov));
296 COMMON(object) = R_NilValue;
297 COMMON(params) = R_NilValue;
298 COMMON(cov) = R_NilValue;
299 COMMON(nvars) = 0;
300 COMMON(npars) = 0;
301 COMMON(ncovars) = 0;
302 COMMON(nreps) = 0;
303
304 switch (COMMON(mode)) {
305
306 case Rfun: {
307
308 R_ReleaseObject(RFUN(fn));
309 R_ReleaseObject(RFUN(args));
310 R_ReleaseObject(RFUN(Snames));
311 RFUN(fn) = R_NilValue;
312 RFUN(args) = R_NilValue;
313 RFUN(Snames) = R_NilValue;
314
315 }
316
317 break;
318
319 case native: case regNative: {
320
321 NAT(fun) = 0;
322 R_ReleaseObject(NAT(args));
323 R_ReleaseObject(NAT(sindex));
324 R_ReleaseObject(NAT(pindex));
325 R_ReleaseObject(NAT(cindex));
326 NAT(args) = R_NilValue;
327 NAT(sindex) = R_NilValue;
328 NAT(pindex) = R_NilValue;
329 NAT(cindex) = R_NilValue;
330
331 }
332
333 break;
334
335 default: // #nocov
336
337 err("in 'pomp_desolve_takedown': unrecognized 'mode'"); // # nocov
338
339 break;
340
341 }
342
343 COMMON(mode) = undef;
344
345 return R_NilValue;
346}

◆ pomp_vf_eval()

void pomp_vf_eval ( int *  neq,
double *  t,
double *  y,
double *  ydot,
double *  yout,
int *  ip 
)

Definition at line 260 of file trajectory.c.

261{
262 switch (COMMON(mode)) {
263
264 case Rfun: // R function
265
266 eval_skeleton_R(ydot,t,y,REAL(COMMON(params)),
267 RFUN(fn),RFUN(args),RFUN(Snames),
268 COMMON(nvars),COMMON(npars),COMMON(ncovars),1,
269 COMMON(nreps),COMMON(nreps),COMMON(nreps),
270 &COMMON(covar_table),REAL(COMMON(cov)));
271
272 break;
273
274 case native: case regNative: // native code
275 eval_skeleton_native(ydot,t,y,REAL(COMMON(params)),
276 COMMON(nvars),COMMON(npars),COMMON(ncovars),1,
277 COMMON(nreps),COMMON(nreps),COMMON(nreps),
278 INTEGER(NAT(sindex)),INTEGER(NAT(pindex)),INTEGER(NAT(cindex)),
279 &COMMON(covar_table),NAT(fun),NAT(args),REAL(COMMON(cov)));
280
281 break;
282
283 default: // #nocov
284
285 err("in 'pomp_vf_eval': unrecognized 'mode'"); // # nocov
286
287 break;
288
289 }
290}
eval_skeleton_R
void eval_skeleton_R(double *, double *, double *, double *, SEXP, SEXP, SEXP, int, int, int, int, int, int, int, lookup_table_t *, double *)
Definition skeleton.c:94
eval_skeleton_native
void eval_skeleton_native(double *, double *, double *, double *, int, int, int, int, int, int, int, int *, int *, int *, lookup_table_t *, pomp_skeleton *, SEXP, double *)
Definition skeleton.c:245
Here is the call graph for this function:

◆ ret_array()

static R_INLINE SEXP ret_array ( int  nvars,
int  nreps,
int  ntimes,
SEXP  Snames,
SEXP  repnames 
)
static

Definition at line 6 of file trajectory.c.

7{
8 SEXP X;
9 int dim[3] = {nvars, nreps, ntimes};
10 const char *dimnms[3] = {"name",".id","time"};
11 PROTECT(X = makearray(3,dim));
12 setrownames(X,Snames,3);
13 setcolnames(X,repnames);
14 fixdimnames(X,dimnms,3);
15 UNPROTECT(1);
16 return X;
17}
fixdimnames
static R_INLINE void fixdimnames(SEXP x, const char **names, int n)
Definition pomp_defines.h:129
setrownames
static R_INLINE void setrownames(SEXP x, SEXP names, int rank)
Definition pomp_defines.h:110
setcolnames
static R_INLINE void setcolnames(SEXP x, SEXP names)
Definition pomp_defines.h:121
makearray
static R_INLINE SEXP makearray(int rank, const int *dim)
Definition pomp_defines.h:40
Here is the call graph for this function:
Here is the caller graph for this function:

Variable Documentation

◆ [struct]

struct { ... } _pomp_vf_eval_block

◆ args

SEXP args

Definition at line 139 of file trajectory.c.

◆ cindex

SEXP cindex

Definition at line 146 of file trajectory.c.

◆ [struct]

struct { ... } common

◆ cov

SEXP cov

Definition at line 129 of file trajectory.c.

◆ covar_table

lookup_table_t covar_table

Definition at line 130 of file trajectory.c.

◆ fn

SEXP fn

Definition at line 138 of file trajectory.c.

◆ fun

pomp_skeleton* fun

Definition at line 147 of file trajectory.c.

◆ mode

pompfunmode mode

Definition at line 126 of file trajectory.c.

◆ [struct]

struct { ... } native_code

◆ ncovars

int ncovars

Definition at line 133 of file trajectory.c.

◆ npars

int npars

Definition at line 132 of file trajectory.c.

◆ nreps

int nreps

Definition at line 134 of file trajectory.c.

◆ nvars

int nvars

Definition at line 131 of file trajectory.c.

◆ object

SEXP object

Definition at line 127 of file trajectory.c.

◆ params

SEXP params

Definition at line 128 of file trajectory.c.

◆ pindex

SEXP pindex

Definition at line 145 of file trajectory.c.

◆ [struct]

struct { ... } R_fun

◆ [union]

union { ... } shared

◆ sindex

SEXP sindex

Definition at line 144 of file trajectory.c.

◆ Snames

SEXP Snames

Definition at line 140 of file trajectory.c.