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

Go to the source code of this file.

Functions

static R_INLINE SEXP add_args (SEXP names, SEXP log, SEXP args)
 
static R_INLINE SEXP eval_call (SEXP fn, SEXP args, double *p, int n)
 
SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi)
 

Function Documentation

◆ add_args()

static R_INLINE SEXP add_args ( SEXP  names,
SEXP  log,
SEXP  args 
)
static

Definition at line 10 of file dprior.c.

11 {
12 
13  SEXP var;
14  int v;
15 
16  PROTECT(log = AS_LOGICAL(log));
17  PROTECT(args = VectorToPairList(args));
18  PROTECT(args = LCONS(log,args));
19  SET_TAG(args,install("log"));
20 
21  for (v = LENGTH(names)-1; v >= 0; v--) {
22  var = NEW_NUMERIC(1);
23  args = LCONS(var,args);
24  UNPROTECT(1);
25  PROTECT(args);
26  SET_TAG(args,installChar(STRING_ELT(names,v)));
27  }
28 
29  UNPROTECT(3);
30  return args;
31 
32 }
SEXP args
Definition: trajectory.c:139
Here is the caller graph for this function:

◆ do_dprior()

SEXP do_dprior ( SEXP  object,
SEXP  params,
SEXP  log,
SEXP  gnsi 
)

Definition at line 51 of file dprior.c.

52 {
53 
55  int npars, nreps;
56  SEXP Pnames, pompfun, fn, args, F;
57  int *dim;
58 
59  PROTECT(params = as_matrix(params));
60  dim = INTEGER(GET_DIM(params));
61  npars = dim[0]; nreps = dim[1];
62 
63  PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params)));
64 
65  // extract the user-defined function
66  PROTECT(pompfun = GET_SLOT(object,install("dprior")));
67  PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode,NA_STRING,Pnames,NA_STRING,NA_STRING));
68 
69  // extract 'userdata' as pairlist
70  PROTECT(args = GET_SLOT(object,install("userdata")));
71 
72  // to store results
73  PROTECT(F = NEW_NUMERIC(nreps));
74 
75  int nprotect = 6;
76 
77  switch (mode) {
78  case Rfun: {
79  SEXP ans;
80  double *ps, *pt;
81  int j;
82 
83  PROTECT(args = add_args(Pnames,log,args)); nprotect++;
84 
85  for (j = 0, ps = REAL(params), pt = REAL(F); j < nreps; j++, ps += npars, pt++) {
86 
87  PROTECT(ans = eval_call(fn,args,ps,npars));
88  *pt = *(REAL(AS_NUMERIC(ans)));
89  UNPROTECT(1);
90 
91  }
92  }
93 
94  break;
95 
96  case native: case regNative: {
97  int give_log, *pidx = 0;
98  pomp_dprior *ff = NULL;
99  double *ps, *pt;
100  int j;
101 
102  // construct state, parameter, covariate, observable indices
103  pidx = INTEGER(GET_SLOT(pompfun,install("paramindex")));
104 
105  // address of native routine
106  *((void **) (&ff)) = R_ExternalPtrAddr(fn);
107 
108  give_log = *(INTEGER(AS_INTEGER(log)));
109 
110  R_CheckUserInterrupt(); // check for user interrupt
111 
112  // loop over replicates
113  for (j = 0, pt = REAL(F), ps = REAL(params); j < nreps; j++, ps += npars, pt++)
114  (*ff)(pt,ps,give_log,pidx);
115 
116  }
117 
118  break;
119 
120  default: {
121  int give_log, j;
122  double *pt;
123 
124  give_log = *(INTEGER(AS_INTEGER(log)));
125 
126  // loop over replicates
127  for (j = 0, pt = REAL(F); j < nreps; j++, pt++)
128  *pt = (give_log) ? 0.0 : 1.0;
129 
130  }
131 
132  }
133 
134  UNPROTECT(nprotect);
135  return F;
136 }
SEXP pomp_fun_handler(SEXP, SEXP, pompfunmode *, SEXP, SEXP, SEXP, SEXP)
Definition: pomp_fun.c:30
static R_INLINE SEXP eval_call(SEXP fn, SEXP args, double *p, int n)
Definition: dprior.c:34
static R_INLINE SEXP add_args(SEXP names, SEXP log, SEXP args)
Definition: dprior.c:10
void pomp_dprior(double *lik, const double *p, int give_log, const int *parindex)
Definition: pomp.h:111
pompfunmode
Definition: pomp_defines.h:16
@ Rfun
Definition: pomp_defines.h:16
@ native
Definition: pomp_defines.h:16
@ undef
Definition: pomp_defines.h:16
@ regNative
Definition: pomp_defines.h:16
static R_INLINE SEXP as_matrix(SEXP x)
Definition: pomp_defines.h:145
int npars
Definition: trajectory.c:132
SEXP params
Definition: trajectory.c:128
pompfunmode mode
Definition: trajectory.c:126
int nreps
Definition: trajectory.c:134
SEXP fn
Definition: trajectory.c:138
Here is the call graph for this function:

◆ eval_call()

static R_INLINE SEXP eval_call ( SEXP  fn,
SEXP  args,
double *  p,
int  n 
)
static

Definition at line 34 of file dprior.c.

35 {
36 
37  SEXP var = args, ans, ob;
38  int v;
39 
40  for (v = 0; v < n; v++, p++, var=CDR(var))
41  *(REAL(CAR(var))) = *p;
42 
43  PROTECT(ob = LCONS(fn,args));
44  PROTECT(ans = eval(ob,CLOENV(fn)));
45 
46  UNPROTECT(2);
47  return ans;
48 
49 }
Here is the caller graph for this function: