[Pomp-commits] r1097 - in pkg/pomp: . R src

[noreply at r-forge.r-project.org]

Author: kingaa
Date: 2015-02-26 10:43:02 +0100 (Thu, 26 Feb 2015)
New Revision: 1097

Modified:
   pkg/pomp/NAMESPACE
   pkg/pomp/R/builder.R
   pkg/pomp/src/pomp_fun.c
Log:
- use .Call interface for load-stack adjustments

Modified: pkg/pomp/NAMESPACE
===================================================================
--- pkg/pomp/NAMESPACE	2015-02-26 09:42:56 UTC (rev 1096)
+++ pkg/pomp/NAMESPACE	2015-02-26 09:43:02 UTC (rev 1097)
@@ -7,6 +7,7 @@
           euler_model_simulator,
           euler_model_density,
           lookup_in_table,
+          load_stack_incr,load_stack_decr,
           SSA_simulator,
           R_Euler_Multinom,D_Euler_Multinom,R_GammaWN,
           mif_update,

Modified: pkg/pomp/R/builder.R
===================================================================
--- pkg/pomp/R/builder.R	2015-02-26 09:42:56 UTC (rev 1096)
+++ pkg/pomp/R/builder.R	2015-02-26 09:43:02 UTC (rev 1097)
@@ -83,7 +83,7 @@
       dyn.load(lib[2])
       if (verbose) cat("loading",sQuote(lib[2]),"\n")
     }
-    .C("__pomp_load_stack_incr",PACKAGE=lib[1])
+    .Call(load_stack_incr,lib[1])
   }
   invisible(NULL)
 }
@@ -91,8 +91,7 @@
 pompUnload.internal <- function (object, ..., verbose = getOption("verbose",FALSE)) {
   for (lib in object at solibfile) {
     if (is.loaded("__pomp_load_stack_decr",PACKAGE=lib[1])) {
-      st <- .C("__pomp_load_stack_decr",st=integer(1),PACKAGE=lib[1])$st
-      stopifnot(st>=0)
+      st <- .Call(load_stack_decr,lib[1])
       if (st==0) {
         dyn.unload(lib[2])
         if (verbose) cat("unloading",sQuote(lib[2]),"\n")
@@ -125,15 +124,19 @@
 
 header <- list(
                file="/* pomp model file: {%name%} */\n\n#include <{%pompheader%}>\n#include <R_ext/Rdynload.h>\n\n",
+               registration="
+void R_init_{%name%} (DllInfo *info) {
+  R_RegisterCCallable(\"{%name%}\", \"__pomp_load_stack_incr\", (DL_FUNC) __pomp_load_stack_incr);
+  R_RegisterCCallable(\"{%name%}\", \"__pomp_load_stack_decr\", (DL_FUNC) __pomp_load_stack_decr);
+}\n\n",
                stackhandling="
 static int __pomp_load_stack = 0;\n
 void __pomp_load_stack_incr (void) {
   ++__pomp_load_stack;
 }\n
 void __pomp_load_stack_decr (int *val) {
-  *val = (--__pomp_load_stack);
-}
-",
+  *val = --__pomp_load_stack;
+}\n",
                rmeasure="\nvoid {%name%}_rmeasure (double *__y, double *__x, double *__p, int *__obsindex, int *__stateindex, int *__parindex, int *__covindex, int __ncovars, double *__covars, double t)\n{\n",
                dmeasure= "\nvoid {%name%}_dmeasure (double *__lik, double *__y, double *__x, double *__p, int give_log, int *__obsindex, int *__stateindex, int *__parindex, int *__covindex, int __ncovars, double *__covars, double t)\n{\n",
                step.fn="\nvoid {%name%}_stepfn (double *__x, const double *__p, const int *__stateindex, const int *__parindex, const int *__covindex, int __covdim, const double *__covars, double t, double dt)\n{\n",
@@ -144,7 +147,6 @@
                dprior="\nvoid {%name%}_dprior (double *__lik, double *__p, int give_log, int *__parindex)\n{\n"
                )
 
-
 fnames <- list(
                rmeasure="{%name%}_rmeasure",
                dmeasure= "{%name%}_dmeasure",
@@ -209,8 +211,6 @@
   if (is.null(name)) name <- randomName()
   if (is.null(dir)) dir <- tempdir()
 
-  has.trans <- !(missing(parameter.transform))
-
   if (missing(globals)) globals <- ""
 
   name <- cleanForC(name)
@@ -264,17 +264,20 @@
   }
   cat(file=out,render(define$var.alt,variable="lik",ptr='__lik',index=0))
 
-  if (has.trans) {
-    ## parameter transformation function
-    cat(file=out,render(header$parameter.transform,name=name))
-    cat(file=out,callable.decl(parameter.transform))
-    cat(file=out,parameter.transform,footer$parameter.transform)
-    ## inverse parameter transformation function
-    cat(file=out,render(header$parameter.inv.transform,name=name))
-    cat(file=out,callable.decl(parameter.inv.transform))
-    cat(file=out,parameter.inv.transform,footer$parameter.inv.transform)
-  }
+  ## parameter transformation function
+  if (missing(parameter.transform))
+    parameter.transform <- missing.fun("parameter.transform")
+  cat(file=out,render(header$parameter.transform,name=name))
+  cat(file=out,callable.decl(parameter.transform))
+  cat(file=out,parameter.transform,footer$parameter.transform)
 
+  ## inverse parameter transformation function
+  if (missing(parameter.inv.transform))
+    parameter.inv.transform <- missing.fun("parameter.inv.transform")
+  cat(file=out,render(header$parameter.inv.transform,name=name))
+  cat(file=out,callable.decl(parameter.inv.transform))
+  cat(file=out,parameter.inv.transform,footer$parameter.inv.transform)
+
   ## rmeasure function
   if (missing(rmeasure)) rmeasure <- missing.fun("rmeasure")
   cat(file=out,render(header$rmeasure,name=name),rmeasure,footer$rmeasure)
@@ -325,6 +328,8 @@
 
   cat(file=out,header$stackhandling)
 
+  cat(file=out,render(header$registration,name=name))
+
   close(out)
 
   cflags <- paste0("PKG_CFLAGS=\"",

Modified: pkg/pomp/src/pomp_fun.c
===================================================================
--- pkg/pomp/src/pomp_fun.c	2015-02-26 09:42:56 UTC (rev 1096)
+++ pkg/pomp/src/pomp_fun.c	2015-02-26 09:43:02 UTC (rev 1097)
@@ -42,3 +42,25 @@
   UNPROTECT(nprotect);
   return f;
 }
+
+SEXP load_stack_incr (SEXP pack) {
+  char *pkg;
+  void (*ff)(void);
+  pkg = CHARACTER_DATA(STRING_ELT(pack,0));
+  ff = R_GetCCallable(pkg,"__pomp_load_stack_incr");
+  ff();
+  return R_NilValue;
+}
+
+SEXP load_stack_decr (SEXP pack) {
+  SEXP s;
+  char *pkg;
+  void (*ff)(int *);
+  PROTECT(s = NEW_INTEGER(1));
+  pkg = CHARACTER_DATA(STRING_ELT(pack,0));
+  ff = R_GetCCallable(pkg,"__pomp_load_stack_decr");
+  ff(INTEGER(s));
+  if (*(INTEGER(s)) < 0) error("impossible!");
+  UNPROTECT(1);
+  return s;
+}