more fixes for rchk

kingaa · Apr 1, 2024 · 3d785a9 · 3d785a9
1 parent 268a1ba
commit 3d785a9
Show file tree

Hide file tree

Showing 7 changed files with 24 additions and 14 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: pomp
 Type: Package
 Title: Statistical Inference for Partially Observed Markov Processes
-Version: 5.7.0.1
-Date: 2024-03-30
+Version: 5.7.0.2
+Date: 2024-03-31
 Authors@R: c(person(given=c("Aaron","A."),family="King",role=c("aut","cre"),email="kingaa@umich.edu",comment=c(ORCID="0000-0001-6159-3207")),
 	  person(given=c("Edward","L."),family="Ionides",role="aut",comment=c(ORCID="0000-0002-4190-0174"))	,
 	  person(given="Carles",family="Bretó",role="aut",comment=c(ORCID="0000-0003-4695-4902")),

diff --git a/src/decls.h b/src/decls.h
@@ -100,7 +100,7 @@ extern SEXP synth_loglik(SEXP ysim, SEXP ydat);
 extern SEXP iterate_map(SEXP object, SEXP times, SEXP t0, SEXP x0, SEXP params, SEXP gnsi);
 extern SEXP pomp_desolve_setup(SEXP object, SEXP x0, SEXP params, SEXP gnsi);
 extern void pomp_vf_eval(int *neq, double *t, double *y, double *ydot, double *yout, int *ip);
-extern void pomp_desolve_takedown(void);
+extern SEXP pomp_desolve_takedown(void);
 /* src/transformations.c */
 extern SEXP LogitTransform(SEXP P);
 extern SEXP ExpitTransform(SEXP X);

diff --git a/src/dinit.c b/src/dinit.c
@@ -104,7 +104,7 @@ static SEXP init_density
   int give_log;
   int nvars, npars, nrepsx, nrepsp, nreps, ncovars;
   SEXP Snames, Pnames, Cnames;
-  SEXP fn;
+  SEXP fn, ans;
   SEXP F, cvec;
   double *cov;
   int *dim;
@@ -153,7 +153,11 @@ static SEXP init_density
       double *xs = REAL(X)+nvars*(j%nrepsx);
       double *ps = REAL(params)+npars*(j%nrepsp);
 
-      *ft = *REAL(AS_NUMERIC(eval_call(fn,args,t,xs,nvars,ps,npars,cov,ncovars)));
+      PROTECT(ans = eval_call(fn,args,t,xs,nvars,ps,npars,cov,ncovars));
+
+      *ft = *REAL(AS_NUMERIC(ans));
+
+      UNPROTECT(1);
 
       if (!give_log) *ft = exp(*ft);
 

diff --git a/src/dprocess.c b/src/dprocess.c
@@ -134,7 +134,7 @@ static SEXP onestep_density
   int give_log;
   int nvars, npars, nrepsx, nrepsp, nreps, ntimes, ncovars;
   SEXP Snames, Pnames, Cnames;
-  SEXP fn;
+  SEXP fn, ans;
   SEXP F, cvec;
   double *cov;
   int *dim;
@@ -194,7 +194,9 @@ static SEXP onestep_density
         double *x1 = x1p+nvars*(j%nrepsx);
         double *x2 = x2p+nvars*(j%nrepsx);
 
-        *ft = *REAL(AS_NUMERIC(eval_call(fn,args,t1,t2,x1,x2,nvars,p,npars,cov,ncovars)));
+        PROTECT(ans = eval_call(fn,args,t1,t2,x1,x2,nvars,p,npars,cov,ncovars));
+        *ft = *REAL(AS_NUMERIC(ans));
+        UNPROTECT(1);
 
         if (!give_log) *ft = exp(*ft);
 

diff --git a/src/rinit.c b/src/rinit.c
@@ -139,7 +139,8 @@ SEXP do_rinit (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi)
     int j;
 
     PROTECT(args = add_args(args,Pnames,Cnames));
-    PROTECT(ans = AS_NUMERIC(eval_call(fn,args,time,ps,npar,cov,ncovars)));
+    PROTECT(ans = eval_call(fn,args,time,ps,npar,cov,ncovars));
+    PROTECT(ans = AS_NUMERIC(ans));
     PROTECT(Snames = GET_NAMES(ans));
 
     if (invalid_names(Snames))
@@ -159,7 +160,7 @@ SEXP do_rinit (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi)
 
     memcpy(xt,xs,nvar*sizeof(double));
 
-    nprotect += 5;
+    nprotect += 6;
 
     for (j = 1, xt += nvar; j < ns; j++, xt += nvar) {
       PROTECT(ans = eval_call(fn,args,time,ps+npar*(j%nrep),npar,cov,ncovars));

diff --git a/src/rprior.c b/src/rprior.c
@@ -95,14 +95,15 @@ SEXP do_rprior (SEXP object, SEXP params, SEXP gnsi)
 
       if (first) {
 
-        PROTECT(ans = AS_NUMERIC(eval_call(fn,args,p,npars)));
+        PROTECT(ans = eval_call(fn,args,p,npars));
+        PROTECT(ans = AS_NUMERIC(ans));
 
         PROTECT(nm = GET_NAMES(ans));
         if (invalid_names(nm))
           err("'rprior' must return a named numeric vector.");
         posn = INTEGER(PROTECT(matchnames(Pnames,nm,"parameters")));
 
-        nprotect += 3;
+        nprotect += 4;
 
         pa = REAL(ans);
         for (i = 0; i < LENGTH(ans); i++) p[posn[i]] = pa[i];
@@ -111,12 +112,13 @@ SEXP do_rprior (SEXP object, SEXP params, SEXP gnsi)
 
       } else {
 
-        PROTECT(ans = AS_NUMERIC(eval_call(fn,args,p,npars)));
+        PROTECT(ans = eval_call(fn,args,p,npars));
+        PROTECT(ans = AS_NUMERIC(ans));
 
         pa = REAL(ans);
         for (i = 0; i < LENGTH(ans); i++) p[posn[i]] = pa[i];
 
-        UNPROTECT(1);
+        UNPROTECT(2);
 
       }
     }

diff --git a/src/trajectory.c b/src/trajectory.c
@@ -289,7 +289,7 @@ void pomp_vf_eval (int *neq, double *t, double *y, double *ydot, double *yout, i
   }
 }
 
-void pomp_desolve_takedown (void) {
+SEXP pomp_desolve_takedown (void) {
   R_ReleaseObject(COMMON(object));
   R_ReleaseObject(COMMON(params));
   R_ReleaseObject(COMMON(cov));
@@ -342,6 +342,7 @@ void pomp_desolve_takedown (void) {
 
   COMMON(mode) = undef;
 
+  return R_NilValue;
 }
 
 #undef COMMON