fix ETA sizing in touch_funs #68

metrumresearchgroup · Jul 5, 2016 · 24c25e5 · 24c25e5
1 parent 2a2c793
commit 24c25e5
Show file tree

Hide file tree

Showing 8 changed files with 32 additions and 10 deletions.
diff --git a/rdev/R/RcppExports.R b/rdev/R/RcppExports.R
@@ -17,8 +17,8 @@ CALLINIT <- function(Nparam, Ninit, xifun) {
     .Call('mrgsolve_CALLINIT', PACKAGE = 'mrgsolve', Nparam, Ninit, xifun)
 }
 
-TOUCH_FUNS <- function(lparam, linit, capture, xifun, xtfun, xdfun) {
-    .Call('mrgsolve_TOUCH_FUNS', PACKAGE = 'mrgsolve', lparam, linit, capture, xifun, xtfun, xdfun)
+TOUCH_FUNS <- function(lparam, linit, Neta, Neps, capture, xifun, xtfun, xdfun) {
+    .Call('mrgsolve_TOUCH_FUNS', PACKAGE = 'mrgsolve', lparam, linit, Neta, Neps, capture, xifun, xtfun, xdfun)
 }
 
 MVGAUSS <- function(OMEGA_, n, seed) {

diff --git a/rdev/R/mrgsolve.R b/rdev/R/mrgsolve.R
@@ -555,8 +555,10 @@ touch_funs <- function(x) {
     cfun <- config_function_pointer(x)
     param <- as.numeric(param(x))
     init <- as.numeric(x@init)
+    neta <- sum(nrow(omat(x)))
+    neps <- sum(nrow(smat(x)))
 
-    out <- .Call(mrgsolve_TOUCH_FUNS,param,init,x@capture,ifun, tfun, dfun)
+    out <- .Call(mrgsolve_TOUCH_FUNS,param,init,neta,neps,x@capture,ifun, tfun, dfun)
     names(out$init) <- names(init)
     out
 }

diff --git a/rdev/inst/project/housemodel.RDS b/rdev/inst/project/housemodel.RDS
diff --git a/rdev/src/RcppExports.cpp b/rdev/src/RcppExports.cpp
@@ -64,18 +64,20 @@ BEGIN_RCPP
 END_RCPP
 }
 // TOUCH_FUNS
-Rcpp::List TOUCH_FUNS(Rcpp::NumericVector lparam, Rcpp::NumericVector linit, Rcpp::CharacterVector capture, SEXP xifun, SEXP xtfun, SEXP xdfun);
-RcppExport SEXP mrgsolve_TOUCH_FUNS(SEXP lparamSEXP, SEXP linitSEXP, SEXP captureSEXP, SEXP xifunSEXP, SEXP xtfunSEXP, SEXP xdfunSEXP) {
+Rcpp::List TOUCH_FUNS(Rcpp::NumericVector lparam, Rcpp::NumericVector linit, int Neta, int Neps, Rcpp::CharacterVector capture, SEXP xifun, SEXP xtfun, SEXP xdfun);
+RcppExport SEXP mrgsolve_TOUCH_FUNS(SEXP lparamSEXP, SEXP linitSEXP, SEXP NetaSEXP, SEXP NepsSEXP, SEXP captureSEXP, SEXP xifunSEXP, SEXP xtfunSEXP, SEXP xdfunSEXP) {
 BEGIN_RCPP
     Rcpp::RObject __result;
     Rcpp::RNGScope __rngScope;
     Rcpp::traits::input_parameter< Rcpp::NumericVector >::type lparam(lparamSEXP);
     Rcpp::traits::input_parameter< Rcpp::NumericVector >::type linit(linitSEXP);
+    Rcpp::traits::input_parameter< int >::type Neta(NetaSEXP);
+    Rcpp::traits::input_parameter< int >::type Neps(NepsSEXP);
     Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type capture(captureSEXP);
     Rcpp::traits::input_parameter< SEXP >::type xifun(xifunSEXP);
     Rcpp::traits::input_parameter< SEXP >::type xtfun(xtfunSEXP);
     Rcpp::traits::input_parameter< SEXP >::type xdfun(xdfunSEXP);
-    __result = Rcpp::wrap(TOUCH_FUNS(lparam, linit, capture, xifun, xtfun, xdfun));
+    __result = Rcpp::wrap(TOUCH_FUNS(lparam, linit, Neta, Neps, capture, xifun, xtfun, xdfun));
     return __result;
 END_RCPP
 }

diff --git a/rdev/src/dataobject.cpp b/rdev/src/dataobject.cpp
@@ -64,7 +64,17 @@ void dataobject::locate_tran() {
 
   int zeros = Data.ncol()-1;
 
-  if(zeros==0) return;
+  if(zeros==0) {
+    col["amt"]  = 0;
+    col["ii"]   = 0;
+    col["addl"] = 0;
+    col["ss"]   = 0;
+    col["rate"] = 0;
+    col["evid"] = 0;
+    col["cmt"]  = 0;
+    col["time"] = 0;
+    return;
+  }
 
   svec::const_iterator bg = Data_names.begin();
   svec::const_iterator ed = Data_names.end();
@@ -81,6 +91,8 @@ void dataobject::locate_tran() {
 
   col["time"] = tcol;
 
+
+
   if(lc) {
     col["amt"]  = std::find(bg,ed,"amt")  - bg;
     col["ii"]   = std::find(bg,ed,"ii")   - bg;

diff --git a/rdev/src/devtran.cpp b/rdev/src/devtran.cpp
@@ -182,8 +182,9 @@ Rcpp::List DEVTRAN(Rcpp::List parin,
   neq = prob->neq();
   prob->advan(advan);
   prob->resize_capture(size_capture);
-  prob->init_call_record(time0);
 
+  //prob->init_call_record(time0);
+
 
   switch(advan) {
   case 13:
@@ -305,6 +306,8 @@ Rcpp::List DEVTRAN(Rcpp::List parin,
     neps = eps.n_cols;
   }
   prob->neps(SIGMA.ncol());
+  prob->init_call_record(time0);
+
 
   // Figure out the output data set:
   const unsigned int n_out_col  = 2 + n_tran_carry + n_data_carry + n_idata_carry + nreq + ntable + n_capture;

diff --git a/rdev/src/mrgsolve.cpp b/rdev/src/mrgsolve.cpp
@@ -117,6 +117,7 @@ Rcpp::NumericVector CALLINIT(Rcpp::NumericVector Nparam, Rcpp::NumericVector Nin
 // [[Rcpp::export]]
 Rcpp::List TOUCH_FUNS(Rcpp::NumericVector lparam, 
                       Rcpp::NumericVector linit,
+                      int Neta, int Neps,
                       Rcpp::CharacterVector capture,
                       SEXP xifun, SEXP xtfun, SEXP xdfun) {
 
@@ -130,6 +131,8 @@ Rcpp::List TOUCH_FUNS(Rcpp::NumericVector lparam,
   prob->Rodeproblem::init_fun(xifun);
   prob->Rodeproblem::table_fun(xtfun);
   prob->resize_capture(capture.size());
+  prob->neta(Neta);
+  prob->neps(Neps);
 
   double time = 0;
   prob->time(time);

diff --git a/rdev/src/odeproblem.cpp b/rdev/src/odeproblem.cpp
@@ -85,11 +85,11 @@ odeproblem::odeproblem(int npar_,int neq_) : odepack_dlsoda(npar_,neq_) {
 odeproblem::~odeproblem(){}
 
 void odeproblem::neta(int n) {
-  if(n > 50) d.ETA.assign(n,0.0);
+  if(n > 25) d.ETA.assign(n,0.0);
 }
 
 void odeproblem::neps(int n) {
-  if(n > 50) d.EPS.assign(n,0.0);
+  if(n > 25) d.EPS.assign(n,0.0);
 }