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

Go to the source code of this file.

Enumerations

enum  direction_t { to = 1 , from = -1 }
 

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)
 
SEXP do_partrans (SEXP object, SEXP params, SEXP dir, SEXP gnsi)
 

Enumeration Type Documentation

◆ direction_t

enum direction_t
Enumerator
to 
from 

Definition at line 10 of file partrans.c.

10{to = 1, from = -1} direction_t;
direction_t
direction_t
Definition partrans.c:10
from
@ from
Definition partrans.c:10
to
@ to
Definition partrans.c:10

Function Documentation

◆ add_args()

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

Definition at line 12 of file partrans.c.

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

◆ do_partrans()

SEXP do_partrans ( SEXP  object,
SEXP  params,
SEXP  dir,
SEXP  gnsi 
)

Definition at line 49 of file partrans.c.

50{
51
52 SEXP Pnames, tparams, pompfun, fn, args, ob;
53 pompfunmode mode = undef;
54 direction_t direc;
55 int qvec, npars, nreps;
56 int *dim;
57
58 qvec = isNull(GET_DIM(params)); // is 'params' a vector?
59
60 PROTECT(tparams = duplicate(params));
61
62 // coerce 'params' to matrix
63 PROTECT(tparams = as_matrix(tparams));
64 dim = INTEGER(GET_DIM(tparams));
65 npars = dim[0]; nreps = dim[1];
66
67 PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(tparams)));
68
69 // determine direction of transformation and extract corresponding pomp_fun
70 direc = (direction_t) *(INTEGER(dir));
71 PROTECT(ob = GET_SLOT(object,install("partrans")));
72 switch (direc) {
73 case from: default: // from estimation scale
74 PROTECT(pompfun = GET_SLOT(ob,install("from")));
75 break;
76 case to: // to estimation scale
77 PROTECT(pompfun = GET_SLOT(ob,install("to")));
78 break;
79 }
80
81 PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode,NA_STRING,Pnames,NA_STRING,NA_STRING));
82
83 // extract 'userdata' as pairlist
84 PROTECT(args = GET_SLOT(object,install("userdata")));
85
86 int nprotect = 7;
87
88 switch (mode) {
89
90 case Rfun: {
91
92 SEXP ans, nm;
93 double *pa, *ps = REAL(tparams);
94 int *posn;
95 int i, j;
96
97 PROTECT(args = add_args(args,Pnames));
98 PROTECT(ans = eval_call(fn,args,ps,npars));
99
100 PROTECT(nm = GET_NAMES(ans));
101 if (invalid_names(nm))
102 err("user transformation functions must return named numeric vectors.");
103 posn = INTEGER(PROTECT(matchnames(Pnames,nm,"parameters")));
104
105 nprotect += 4;
106
107 pa = REAL(AS_NUMERIC(ans));
108
109 for (i = 0; i < LENGTH(ans); i++) ps[posn[i]] = pa[i];
110
111 for (j = 1, ps += npars; j < nreps; j++, ps += npars) {
112
113 PROTECT(ans = eval_call(fn,args,ps,npars));
114 pa = REAL(AS_NUMERIC(ans));
115 for (i = 0; i < LENGTH(ans); i++) ps[posn[i]] = pa[i];
116 UNPROTECT(1);
117
118 }
119
120 }
121
122 break;
123
124 case native: case regNative: {
125
126 pomp_transform *ff;
127 double *ps, *pt;
128 int *idx;
129 int j;
130
131 *((void **) (&ff)) = R_ExternalPtrAddr(fn);
132
133 R_CheckUserInterrupt();
134
135 idx = INTEGER(GET_SLOT(pompfun,install("paramindex")));
136
137 for (j = 0, ps = REAL(params), pt = REAL(tparams); j < nreps; j++, ps += npars, pt += npars)
138 (*ff)(pt,ps,idx);
139
140 }
141
142 break;
143
144 default: // #nocov
145
146 break; // #nocov
147
148 }
149
150 if (qvec) {
151 PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(tparams))); nprotect++;
152 SET_DIM(tparams,R_NilValue);
153 SET_NAMES(tparams,Pnames);
154 }
155
156 UNPROTECT(nprotect);
157 return tparams;
158
159}
pomp_fun_handler
SEXP pomp_fun_handler(SEXP, SEXP, pompfunmode *, SEXP, SEXP, SEXP, SEXP)
Definition pomp_fun.c:30
eval_call
static R_INLINE SEXP eval_call(SEXP fn, SEXP args, double *p, int n)
Definition partrans.c:33
add_args
static R_INLINE SEXP add_args(SEXP args, SEXP names)
Definition partrans.c:12
err
#define err(...)
Definition pomp.h:21
pomp_transform
void pomp_transform(double *pt, const double *p, const int *parindex)
Definition pomp.h:115
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
invalid_names
static R_INLINE int invalid_names(SEXP names)
Definition pomp_defines.h:55
as_matrix
static R_INLINE SEXP as_matrix(SEXP x)
Definition pomp_defines.h:145
npars
int npars
Definition trajectory.c:132
params
SEXP params
Definition trajectory.c:128
mode
pompfunmode mode
Definition trajectory.c:126
nreps
int nreps
Definition trajectory.c:134
fn
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 33 of file partrans.c.

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