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

Go to the source code of this file.

Functions

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

Function Documentation

◆ add_args()

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

Definition at line 10 of file rprior.c.

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

◆ do_rprior()

SEXP do_rprior ( SEXP  object,
SEXP  params,
SEXP  gnsi 
)

Definition at line 58 of file rprior.c.

59 {
60 
62  int npars, nreps;
63  SEXP Pnames, pompfun, fn, args;
64  int *dim;
65 
66  PROTECT(params = ret_array(params));
67  dim = INTEGER(GET_DIM(params));
68  npars = dim[0]; nreps = dim[1];
69 
70  PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params)));
71 
72  // extract the user-defined function
73  PROTECT(pompfun = GET_SLOT(object,install("rprior")));
74  PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode,NA_STRING,Pnames,NA_STRING,NA_STRING));
75 
76  // extract 'userdata' as pairlist
77  PROTECT(args = GET_SLOT(object,install("userdata")));
78 
79  int nprotect = 5;
80  int first = 1;
81 
82  switch (mode) {
83 
84  case Rfun: {
85 
86  SEXP ans, nm;
87  double *pa, *p = REAL(params);
88  int *posn = NULL;
89  int i, j;
90 
91  // set up the function call
92  PROTECT(args = add_args(args,Pnames)); nprotect++;
93 
94  for (j = 0; j < nreps; j++, p += npars) {
95 
96  if (first) {
97 
98  PROTECT(ans = eval_call(fn,args,p,npars));
99  PROTECT(ans = AS_NUMERIC(ans));
100 
101  PROTECT(nm = GET_NAMES(ans));
102  if (invalid_names(nm))
103  err("'rprior' must return a named numeric vector.");
104  posn = INTEGER(PROTECT(matchnames(Pnames,nm,"parameters")));
105 
106  nprotect += 4;
107 
108  pa = REAL(ans);
109  for (i = 0; i < LENGTH(ans); i++) p[posn[i]] = pa[i];
110 
111  first = 0;
112 
113  } else {
114 
115  PROTECT(ans = eval_call(fn,args,p,npars));
116  PROTECT(ans = AS_NUMERIC(ans));
117 
118  pa = REAL(ans);
119  for (i = 0; i < LENGTH(ans); i++) p[posn[i]] = pa[i];
120 
121  UNPROTECT(2);
122 
123  }
124  }
125  }
126 
127  break;
128 
129  case native: case regNative: {
130 
131  double *p;
132  int *pidx = 0;
133  pomp_rprior *ff = NULL;
134  int j;
135 
136  // extract parameter index
137  pidx = INTEGER(GET_SLOT(pompfun,install("paramindex")));
138 
139  // address of native routine
140  *((void **) (&ff)) = R_ExternalPtrAddr(fn);
141 
142  R_CheckUserInterrupt(); // check for user interrupt
143 
144  GetRNGstate();
145 
146  // loop over replicates
147  for (j = 0, p = REAL(params); j < nreps; j++, p += npars)
148  (*ff)(p,pidx);
149 
150  PutRNGstate();
151 
152  }
153 
154  break;
155 
156  default: // just duplicate
157 
158  warn("'rprior' unspecified: duplicating parameters.");
159 
160  }
161 
162  UNPROTECT(nprotect);
163  return params;
164 }
SEXP pomp_fun_handler(SEXP, SEXP, pompfunmode *, SEXP, SEXP, SEXP, SEXP)
Definition: pomp_fun.c:30
#define warn(...)
Definition: pomp.h:22
void pomp_rprior(double *p, const int *parindex)
Definition: pomp.h:107
#define err(...)
Definition: pomp.h:21
static R_INLINE SEXP matchnames(SEXP provided, SEXP needed, const char *where)
Definition: pomp_defines.h:60
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 int invalid_names(SEXP names)
Definition: pomp_defines.h:55
static R_INLINE SEXP eval_call(SEXP fn, SEXP args, double *p, int n)
Definition: rprior.c:31
static R_INLINE SEXP ret_array(SEXP params)
Definition: rprior.c:47
static R_INLINE SEXP add_args(SEXP args, SEXP names)
Definition: rprior.c:10
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 31 of file rprior.c.

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

◆ ret_array()

static R_INLINE SEXP ret_array ( SEXP  params)
static

Definition at line 47 of file rprior.c.

48 {
49  const char *dimnm[2] = {"name", ".id"};
50  SEXP P;
51  PROTECT(P = as_matrix(params));
52  fixdimnames(P,dimnm,2);
53  UNPROTECT(1);
54  return P;
55 
56 }
static R_INLINE void fixdimnames(SEXP x, const char **names, int n)
Definition: pomp_defines.h:129
static R_INLINE SEXP as_matrix(SEXP x)
Definition: pomp_defines.h:145
Here is the call graph for this function:
Here is the caller graph for this function: