Add $EVENT block

R/Aaaa.R

@@ -74,7 +74,7 @@ GLOBALS$TRAN_FILL_NA <- c(
 )
 GLOBALS[["version"]] <- utils::packageVersion("mrgsolve")
 
-block_list <- c("ENV", "PROB", "PARAM", "INIT",
+block_list <- c("ENV", "PROB", "PARAM", "INIT", "EVENT",
                 "CMT", "ODE", "DES", "MAIN", "TABLE",
                 "FIXED", "CMTN", "THETA", "NMXML", "VCMT",
                 "PKMODEL", "PLUGIN", "INCLUDE", "NAMESPACE",

R/RcppExports.R

@@ -33,6 +33,10 @@ EXPAND_OBSERVATIONS <- function(data, times, to_copy, next_pos) {
     .Call(`_mrgsolve_EXPAND_OBSERVATIONS`, data, times, to_copy, next_pos)
 }
 
+VALIDPOINTERS <- function(x) {
+    .Call(`_mrgsolve_VALIDPOINTERS`, x)
+}
+
 TOUCH_FUNS <- function(funs, mod) {
     .Call(`_mrgsolve_TOUCH_FUNS`, funs, mod)
 }

R/class_mrgmod.R

@@ -16,8 +16,8 @@
 # along with mrgsolve.  If not, see <http://www.gnu.org/licenses/>.
 
 valid_funs <- function(x) {
-  x1 <- length(x)==4
-  x2 <- identical(names(x), c("main", "ode", "table", "config"))
+  x1 <- length(x)==5
+  x2 <- identical(names(x), c("main", "ode", "table", "event", "config"))
   if(x1 & x2) return(list(TRUE,NULL))
   msg <- c(
     "Invalid functions specification.",
@@ -348,6 +348,7 @@ house <- function(...) {
   )
   x@soloc <- dirname(sodll(x))
   x <- compiled(x,TRUE)
+  x <- setpointers(x)
   x <- update(x,...,open=TRUE)
   x
 }
@@ -701,6 +702,7 @@ loadso.mrgmod <- function(x,...) {
   if(inherits(foo, "try-error")) {
     wstop("[loadso] failed to load the model dll file")
   }
+  x <- setpointers(x)
   return(invisible(x))
 }
 
@@ -794,7 +796,8 @@ parin <- function(x) {
     ss_n = 500, 
     ss_fixed = FALSE, 
     interrupt = -1, 
-    etasrc = "omega"
+    etasrc = "omega", 
+    call_event = x@shlib$call_event
   )
 }
 

R/compile.R

@@ -20,6 +20,7 @@ generate_rdefs <- function(pars,
                            func,
                            init_fun="",
                            table_fun="",
+                           event_fun="",
                            config_fun="",
                            model="",omats,smats,
                            set=list(), 
@@ -91,6 +92,7 @@ generate_rdefs <- function(pars,
         c(paste0("#define __INITFUN___ ",init_fun),
           paste0("#define __ODEFUN___ ",func),
           paste0("#define __TABLECODE___ ", table_fun),
+          paste0("#define __EVENTFUN___ ", event_fun), 
           paste0("#define __CONFIGFUN___ ", config_fun),
           paste0("#define __REGISTERFUN___ ", register_fun(model)),
           paste0("#define _nEQ ", ncmt),

R/funset.R

@@ -30,6 +30,7 @@ There was a problem accessing the model shared object.
 main_func   <- function(x) x@funs["main"]
 ode_func    <- function(x) x@funs["ode"]
 table_func  <- function(x) x@funs["table"] 
+event_func  <- function(x) x@funs["event"]
 config_func <- function(x) x@funs["config"]
 info_func   <- function(x) x@funs["info"]
 #nocov end
@@ -42,7 +43,7 @@ clean_symbol <- function(x) {
   gsub("[[:punct:]]", "__", x)
 }
 
-funs_create <- function(model, what = c("main", "ode", "table", "config")) {
+funs_create <- function(model, what = c("main", "ode", "table", "event", "config")) {
   setNames(paste0("_model_", clean_symbol(model), "_", what ,"__"),what)
 }
 
@@ -55,7 +56,7 @@ package_loaded <- function(x) {
 }
 
 funs <- function(x) {
-  x@funs[c("main", "ode", "table", "config")]
+  x@funs[c("main", "ode", "table", "event", "config")]
 }
 
 model_loaded <- function(x) {
@@ -67,47 +68,60 @@ which_loaded <- function(x) {
 }
 
 funs_loaded <- function(x,crump=TRUE) {
-  main_loaded(x) && compiled.mrgmod(x)
+  main_loaded(x) && x@shlib$compiled
 }
 
 all_loaded <- function(x) all(which_loaded(x))  
 
-pointers <- function(x) {
+pointers <- function(x, refresh = FALSE) {
   if(!funs_loaded(x)) {
     try_load <- try(loadso(x), silent = TRUE)
     if(inherits(try_load, "try-error") || !funs_loaded(x)) {
       message(try_load)
       stop(FUNSET_ERROR__)
     }
   }
+  if(!refresh && VALIDPOINTERS(getpointers(x))) {
+    return(getpointers(x))
+  }
   what <- funs(x)
   ans <- getNativeSymbolInfo(what,PACKAGE=dllname(x))
   setNames(lapply(ans, "[[", "address"), names(what))
 }
 
+setpointers <- function(x) {
+  x@shlib$pointers <- pointers(x, refresh = TRUE)
+  x
+}
+
+getpointers <- function(x) {
+  x@shlib$pointers  
+}
+
 funset <- function(x) {
   pkg <- dllname(x)
   ans <- lapply(unname(funs(x)), function(w) {
     loaded <- is.loaded(w,pkg)
     if(loaded) {
       info <- getNativeSymbolInfo(w,pkg)
       name <- info$name
+      addr <- deparse(info$address)
     } else {
       name <- w
+      addr <- "."
     }
-    tibble(name=name,loaded=loaded)
+    tibble(name=name,address=addr,loaded=loaded)
   }) 
 
-  ans <- 
-    bind_rows(unname(ans)) %>% 
-    mutate(func = names(funs(x)))  
+  ans <- bind_rows(unname(ans)) 
+  ans <- mutate(ans, func = names(funs(x)))  
 
-  ans <- as.data.frame(ans[,c("name", "loaded"),drop=FALSE])
+  ans <- as.data.frame(ans[,c("func", "name", "address", "loaded"),drop=FALSE])
 
   shlib <- tibble(
-    package=pkg,
-    version=as.character(build_version(x)),
-    compiled=compiled(x)
+    package = pkg,
+    version = as.character(build_version(x)),
+    compiled = compiled(x)
   )
 
   list(symbols = ans, shlib = data.frame(shlib))

R/modspec.R

@@ -368,7 +368,7 @@ param_re_find <- "\\bparam\\s+\\w+\\s*="
 # please-deprecate
 move_global <- function(x,env) {
 
-  what <- intersect(c("PREAMBLE","MAIN", "ODE", "TABLE", "PRED"),names(x))
+  what <- intersect(c("PREAMBLE","MAIN", "ODE", "TABLE", "EVENT", "PRED"),names(x))
 
   if(length(what)==0) return(x)
 
@@ -495,12 +495,17 @@ move_global2 <- function(spec, env, build) {
   if(!is.null(table$code)) {
     spec$TABLE <- table$code
   }
+  event <- c_vars(spec[["EVENT"]], context = "event")  
+  if(!is.null(event$code)) {
+    spec$EVENT <- event$code
+  }
   to_ns <- bind_rows(
     pream$vars,
     pred$vars,
     main$vars,
     ode$vars,
-    table$vars
+    table$vars, 
+    event$vars
   )
   vars <- bind_rows(glob$vars, to_ns)
   if(any(cap <- to_ns$type=="capture")) {
@@ -536,7 +541,7 @@ move_global2 <- function(spec, env, build) {
 }
 
 find_cpp_dot <- function(spec, env) {
-  to_check <- c("PREAMBLE", "MAIN", "PRED", "ODE", "TABLE", "GLOBAL")
+  to_check <- c("PREAMBLE", "MAIN", "PRED", "ODE", "EVENT", "TABLE", "GLOBAL")
   x <- spec[names(spec) %in% to_check]
   x <- unlist(x, use.names = FALSE)
   # Narrow the search first; 10x speed up when searching for `pattern`

R/mread.R

@@ -339,6 +339,7 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
     ode_func(x),
     main_func(x),
     table_func(x),
+    event_func(x),
     config_func(x),
     model = model(x),
     omats = omat(x),
@@ -461,6 +462,7 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
   x@shlib[["nm_import"]] <- mread.env[["nm_import"]]
   x@shlib[["source"]] <- file.path(build[["soloc"]],build[["compfile"]])
   x@shlib[["md5"]] <- build[["md5"]]
+  x@shlib[["call_event"]] <- "EVENT" %in% names(spec)
 
   # build----
   # In soloc directory
@@ -536,6 +538,10 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
     dbs[["ode"]],
     spec[["ODE"]], 
     "__END_ode__",
+    "\n// MODELED EVENTS:", 
+    "__BEGIN_event__", 
+    spec[["EVENT"]],
+    "__END_event__",
     "\n// TABLE CODE BLOCK:",
     "__BEGIN_table__",
     dbs[["cmt"]],
@@ -595,6 +601,8 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
 
   x <- compiled(x,TRUE)
 
+  x <- setpointers(x)
+
   return(x)
 }
 
@@ -636,7 +644,7 @@ mread_cache <- function(model = NULL,
 
   if(all(t0,t1,t2,t3,t4,te)) {
     if(!quiet) message("Loading model from cache.")
-    loadso(x)
+    x <- loadso(x)
     return(update(x,...,strict=FALSE))
   }
 

inst/base/modelheader.h

@@ -65,6 +65,8 @@ typedef double capture;
 #define __END_main__ __DONE__
 #define __BEGIN_table__ extern "C" { void __TABLECODE___(MRGSOLVE_TABLE_SIGNATURE) {
 #define __END_table__ __DONE__
+#define __BEGIN_event__ extern "C" {void __EVENTFUN___(MRGSOLVE_EVENT_SIGNATURE) {
+#define __END_event__ __DONE__
 #define __DONE__ }}
 
 

inst/base/mrgsolv.h

@@ -140,4 +140,8 @@ typedef std::vector<double> dvec;
 #define MRGSOLVE_CONFIG_SIGNATURE databox& self, const dvec& _THETA_, const double neq, const double npar
 #define MRGSOLVE_CONFIG_SIGNATURE_N 4
 
+//! signature for <code>$EVENT</code>
+#define MRGSOLVE_EVENT_SIGNATURE const dvec& _A_, const dvec& _A_0_,  dvec& _THETA_,  const dvec& _F_, const dvec& _R_,  databox& self, const dvec& _pred_, dvec& _capture_, mrgsolve::resim& simeps
+#define MRGSOLVE_EVENT_SIGNATURE_N 9
+
 #endif

inst/include/odeproblem.h

@@ -48,6 +48,9 @@ typedef void (*init_func)(MRGSOLVE_INIT_SIGNATURE);
 //! <code>$TABLE</code> function
 typedef void (*table_func)(MRGSOLVE_TABLE_SIGNATURE);
 
+//! <code>$EVENT</code> function
+typedef void (*event_func)(MRGSOLVE_EVENT_SIGNATURE);
+
 //! <code>$ODE</code> function
 typedef void (*deriv_func)(MRGSOLVE_ODE_SIGNATURE);
 
@@ -115,6 +118,7 @@ class odeproblem {
 
   void table_call();
   void table_init_call();
+  void event_call();
   void config_call();
 
   void set_d(rec_ptr this_rec);
@@ -249,6 +253,7 @@ class odeproblem {
   deriv_func Derivs; ///< <code>$ODE</code> function
   init_func Inits; ///< <code>$MAIN</code> function
   table_func Table; ///< <code>$TABLE</code> function
+  event_func Event; ///< <code>$EVENT</code> function
   config_func Config; ///< <code>$PREAMBLE</code> function
 
   bool Do_Init_Calc; ///< Flag regulating whether or not initials are taken from <code>$MAIN</code>

src/RcppExports.cpp

@@ -110,6 +110,17 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// VALIDPOINTERS
+bool VALIDPOINTERS(Rcpp::List x);
+RcppExport SEXP _mrgsolve_VALIDPOINTERS(SEXP xSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< Rcpp::List >::type x(xSEXP);
+    rcpp_result_gen = Rcpp::wrap(VALIDPOINTERS(x));
+    return rcpp_result_gen;
+END_RCPP
+}
 // TOUCH_FUNS
 Rcpp::List TOUCH_FUNS(const Rcpp::List& funs, const Rcpp::S4 mod);
 RcppExport SEXP _mrgsolve_TOUCH_FUNS(SEXP funsSEXP, SEXP modSEXP) {

src/devtran.cpp

@@ -61,6 +61,7 @@ Rcpp::List DEVTRAN(const Rcpp::List parin,
   const bool tad              = Rcpp::as<bool>   (parin["tad"]);
   const bool nocb             = Rcpp::as<bool>   (parin["nocb"]);
   bool obsaug                 = Rcpp::as<bool>   (parin["obsaug"] );
+  bool call_event             = Rcpp::as<bool>   (parin["call_event"]);
   obsaug = obsaug & (data.nrow() > 0);
 
   // Grab items from the model object --------------------
@@ -615,8 +616,12 @@ Rcpp::List DEVTRAN(const Rcpp::List parin,
         }
       }
 
-      if(!this_rec->is_lagged()) {
-        prob.table_call();
+      if(call_event) {
+        prob.event_call();
+      } else {
+        if(!this_rec->is_lagged()) {
+          prob.table_call();
+        }
       }
 
       if(prob.any_mtime()) {
@@ -716,7 +721,11 @@ Rcpp::List DEVTRAN(const Rcpp::List parin,
         used_mtimehx = mtimehx.size() > 0;
         prob.clear_mtime();
       } // Close handling of modeled events
-
+
+      if(call_event && !this_rec->is_lagged()) {
+        prob.table_call();
+      }
+
       if(this_rec->output()) {
         ans(crow,0) = id;
         ans(crow,1) = tto;

src/housemodel-mread-header.h

@@ -41,6 +41,7 @@ typedef double localdouble;
 #define __INITFUN___ _model_housemodel_main__
 #define __ODEFUN___ _model_housemodel_ode__
 #define __TABLECODE___ _model_housemodel_table__
+#define __EVENTFUN___ _model_housemodel_event__
 #define __CONFIGFUN___ _model_housemodel_config__
 #define __REGISTERFUN___ R_init_housemodel
 #define _nEQ 3

src/housemodel-mread-source.cpp

@@ -24,6 +24,10 @@ dxdt_CENT = KAi*GUT - (CLi/VCi)*CENT;
 dxdt_RESP = KIN*(1-INH) - KOUTi*RESP;
 __END_ode__
 
+// MODELED EVENTS:
+__BEGIN_event__
+__END_event__
+
 // TABLE CODE BLOCK:
 __BEGIN_table__
 DV = CP*exp(EXPO);

src/mrgsolve.cpp

@@ -454,4 +454,13 @@ Rcpp::List mat2df(Rcpp::NumericMatrix const& x) {
 
 #endif
 
-
+// [[Rcpp::export]]
+bool VALIDPOINTERS(Rcpp::List x) {
+  if(x.size()==0) return false;
+  for(size_t i = 0; i < x.size(); ++i) {
+    if(R_ExternalPtrAddr(x[i]) == NULL) {
+      return false;  
+    }
+  }
+  return true;
+}