From 24c25e5071ac66e7a828ce593bab9b0f6655e8ab Mon Sep 17 00:00:00 2001 From: kylebmetrum Date: Tue, 5 Jul 2016 11:45:08 -0500 Subject: [PATCH] fix ETA sizing in touch_funs #68 --- rdev/R/RcppExports.R | 4 ++-- rdev/R/mrgsolve.R | 4 +++- rdev/inst/project/housemodel.RDS | Bin 1535 -> 1534 bytes rdev/src/RcppExports.cpp | 8 +++++--- rdev/src/dataobject.cpp | 14 +++++++++++++- rdev/src/devtran.cpp | 5 ++++- rdev/src/mrgsolve.cpp | 3 +++ rdev/src/odeproblem.cpp | 4 ++-- 8 files changed, 32 insertions(+), 10 deletions(-) diff --git a/rdev/R/RcppExports.R b/rdev/R/RcppExports.R index 819a7a84e..c0ac3ac60 100644 --- 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 index bdaa61d4a..7739a19da 100644 --- 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 index c53f0f413f30892eb1689668acd61073c92ebe11..50c43bbffe4e96937d9cda2caf9680230a12c1e1 100644 GIT binary patch literal 1534 zcmV729Y>`$Jr3WBgC#N+S_cPxHW5E4u9E+!;|6?i7?o~E`yx(=NL+}8raD^f|6wo$RT zvsv;)S3S{^e8^g7GHcZ;thHBUt@DQ0il0`Wd(Fgo!&is4PmlzNFQ6S?60aRRWeT<9 zXN)s(Aa6^aWpM`GpNQq^Q@?#uJ*~rY)%DN4rUPMMo!A~%f+;E3A&j?=E!J%7j@L}L zO}(#bM1l6-9A&DH+b?jJa8XU`R@XMQA>rV0+iG)A-pJ)1!3wb!ppv?&5RC(^_RN7z zJPDTqre^YAmc_oM4#9hIh%K>WYVcWG+_uEh1EpnONTaP!HcNfyVykB;r5D`?61}>8 zu_2x~dcS5|Jm0$?3WsH0kha5psUSYHDff$48fl4L)e-eAH#`N}wiGfHRl{~fUz;=D z!4{=ln~ZBHAaPsGp)y z$(I9_ICF9}H6&Kcw8K`&sqX55Gv?@9-FFF($3! zk?oMa@A&SIyHSoOdb(;X7)!w5(ISjG>RSsi%lfEisM;c?&cI-$vE;qG-gK*|IVq?n z{4|>j$~&zZs?!8Mj_yX7PRFXTkZ;AoEsaDF-V76tp^F$-+osV`yAhNhgeg5N4uGm|7ApT2h-berAYr5hURTt>0M`JNwAnEPR^h=k*^jsD%6beFkA&40s zM{KM=oroH45zU?iVrm7773MYG$ckiJ!#4d+5WC`zj;7k)#2V+x0?9%d!>qR2)dR!( z;UzbuTxp@pKs;mK{d)2Ih^cyN^xemoT;O7F7MVhO_%qF@Md2gJ({jH+!bnX*eakjlZcj?mGjE9Up|y<_y%~xgH@)cGQu3B#9Ja zWr+Q4)^0u+lnKbOu;K65W^8AZuw7I9&G)CjMuHM;*c5m^l>8IR_<1c;KRJGk0(*yP z`EsUSIjJ0Zy>hcSt^va zDFF0Y`CLcHtqCe~l|UvH?r*bg4?<8F<)TDC2W3&-xQl2>z#GoccQf))13>~InmNc# z8QzuSqv}4Z;FN^izYys3VE>4LV!Zf9=Cs;CaF{6$%iT`Bk5tZ6il2WtyQL^H#jMb+dOUUyb+Yf zzU9nMW{xWU0=gZ>>i|MK+3c|$BoIe0@m zZtCUo@PHT9Mg^#I4})~n?;zco%;?VKNIC!n=r$&F8A?Y36{M?G#&i_B$z#2+`B>=Z zJnYs4%e=o%GrlQ-0u+qs6Y#J^=J-jKjgvA`oF*-qGP>uPmxnIXDY|mEoXRL5NB2c?x5SIaiSyG&U!nE#8BK&VizDSe}Y`>y|T(%Hu<3-#gy)3w023_m+F0%04-x kxggi`G)mR_X>b6A8LNW(Pa&A=UUyOW2ezsckiruH0NpbD&;S4c literal 1535 zcmVZ6)*&jb&6$D{Ph{xd=Uy{$-tg6-?Gq#c;tOcUm&6bDpE8Am z<7bRBu`h2)o@H?c-J6Kz+Ec%MQai1~bJg|Fy~2Souug1`E5Vc$>=4G=#};e0b;oO_ z+os-EHKIWKZ;mq6$L*K6OSq_}b*pQe+K_PYxNWsLC~xF)k6?vZ3s6bjREWlbR(s~a zCZ2>#0aG*iFUw-zQitHZIK-CNF*W$CEpAz2`M%P!Ur3|PyBp=c^J24SDCL*k`x3pn zeX${)IC_77cz$Hprov&FFG$9DZCeT%imG8dqOZ*v z?_i5ku1&^uDj;!UC=9amRU{+{ad9vMJ^VSE2P=$cYGfR{jWyyE{258Gtf=6W%}_r@ zqmr)%DskrIYHCQVmT8kY5b&op=*|J8`xa?y1RHZO3GA2}Gxqb^>mPoRzTf6C)?!Rr z$0OSzec$n&A9tc0PxN%vSTL4=!J|bOb=0>OV3ze!&rr2ROr3$jN@K};ceUwOQFBsI zP55ax7nFBeHB_ewd>q}iX*wON#zMXo2e&j5L3n+da133C?m5W;g=yih0z(+fe& z@Hk>){cs{`xJ5L35{S?W6f4YYyplLeB6GETGFYF7^o z@5dM1kaDGkE&}n4dH0*e^Ao1(snK_zUT}enyB8xTJRZdG+D+Q zSiYR8S5K-(UT1iax4eLo`~H4r2aqM3u- zl;K@DKC11p3QkGL{hI=v?(ZEjP>dH}%beC42o5uqB8`B1WC43iTO5u(Q<=TP<409i z^4D)Fq@x-H$#s;ac8WcHd;3gQbIe}`*nj#25Opz2y}c#Zb2*OrhV!~l0E`rK09#80 z2S}`q+YdPCn!BRGQJA2fj=u5Ueu#oPNIq0i1xXL0rC{P5=|MFly~asl+~#R(=Z&B= z_AO_AGILb*C&x?8-E1)j_}wD!<{phDbpwHzjQUy4>}KV|9Q1Fw`Io0J&KqJ`%E24j zaZ@jshX=f::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 index 8a435d66e..cfeefa1d0 100644 --- 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 index 975e1198f..8ec9ef9cf 100644 --- 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 index c10d284f9..b5ac47531 100644 --- 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 index 20abbc2be..a9ba76990 100644 --- 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); }