From 587d2c2b0165f5699bc2c09de8e34b17e35029cc Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Thu, 11 Jul 2024 14:25:01 -0500 Subject: [PATCH] Changes to get closer to compiling binary --- R/RcppExports.R | 4 +- inst/include/rxode2.h | 19 +- inst/include/rxode2_control.h | 97 +------- inst/include/rxode2parse.h | 34 +-- inst/include/rxode2parseConvertMethod.h | 57 ----- inst/include/rxode2parseSbuf.h | 1 - src/RcppExports.cpp | 8 +- src/approx.c | 4 +- src/cbindThetaOmega.cpp | 2 +- src/codegen.c | 2 +- src/codegen.h | 5 +- src/cvPost.cpp | 58 +---- src/et.cpp | 9 +- src/etTran.cpp | 77 +++++- src/genModelVars.c | 44 ++-- src/genModelVars.h | 16 +- src/handle_evid.c | 2 +- src/init.c | 10 +- src/lincmt.c | 157 ++++++------ src/lincmtB.cpp | 94 +++----- src/par_solve.cpp | 4 +- src/parseFuns.h | 4 +- src/parseLinCmt.c | 307 ++++++++++++++++++++++++ src/rxData.cpp | 32 ++- src/rxStack.cpp | 5 +- src/rxode2_df.cpp | 6 +- src/rxode2parse.cpp | 217 ----------------- src/rxthreefry.cpp | 2 +- src/seed.cpp | 2 +- src/tran.c | 17 +- src/udf.cpp | 75 ++++-- src/utilc.c | 22 +- 32 files changed, 651 insertions(+), 742 deletions(-) delete mode 100644 inst/include/rxode2parseConvertMethod.h create mode 100644 src/parseLinCmt.c delete mode 100644 src/rxode2parse.cpp diff --git a/R/RcppExports.R b/R/RcppExports.R index f3e8d50a1..ad0e6a527 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -192,8 +192,8 @@ etTransEvidIsObs <- function(isObsSexp) { #' @keywords internal #' #' @export -etTransParse <- function(inData, mv, addCmt = FALSE, dropUnits = FALSE, allTimeVar = FALSE, keepDosingOnly = FALSE, combineDvid = NULL, keep = character(0), addlKeepsCov = FALSE, addlDropSs = TRUE, ssAtDoseTime = TRUE) { - .Call(`_rxode2_etTransParse`, inData, mv, addCmt, dropUnits, allTimeVar, keepDosingOnly, combineDvid, keep, addlKeepsCov, addlDropSs, ssAtDoseTime) +etTrans <- function(inData, mv, addCmt = FALSE, dropUnits = FALSE, allTimeVar = FALSE, keepDosingOnly = FALSE, combineDvid = NULL, keep = character(0), addlKeepsCov = FALSE, addlDropSs = TRUE, ssAtDoseTime = TRUE) { + .Call(`_rxode2_etTrans`, inData, mv, addCmt, dropUnits, allTimeVar, keepDosingOnly, combineDvid, keep, addlKeepsCov, addlDropSs, ssAtDoseTime) } rxEtTransAsDataFrame_ <- function(inData1) { diff --git a/inst/include/rxode2.h b/inst/include/rxode2.h index 8d2da25b4..2ac86c68d 100644 --- a/inst/include/rxode2.h +++ b/inst/include/rxode2.h @@ -7,29 +7,14 @@ #define rxLlikSaveSize 9 #include -#include +#include "rxode2parse.h" #include #include #include #include #include -#define rc_buf_read _rxode2_rc_buf_read -#define sIniTo _rxode2_sIniTo -#define sFree _rxode2_sFree -#define sFreeIni _rxode2_sFreeIni -#define sAppendN _rxode2_sAppendN -#define sAppend _rxode2_sAppend -#define sPrint _rxode2_sPrint -#define lineIni _rxode2_lineIni -#define lineFree _rxode2_lineFree -#define addLine _rxode2_addLine -#define curLineProp _rxode2_curLineProp -#define curLineType _rxode2_curLineType -#define doDot _rxode2_doDot -#define doDot2 _rxode2_doDot2 - -#include +#include "rxode2parseSbuf.h" #include #include diff --git a/inst/include/rxode2_control.h b/inst/include/rxode2_control.h index d84e1f0f0..c41390be7 100644 --- a/inst/include/rxode2_control.h +++ b/inst/include/rxode2_control.h @@ -1,100 +1,5 @@ #pragma once #ifndef __rxode2_control_H__ #define __rxode2_control_H__ -#include -#define Rxc_scale 0 -#define Rxc_method 1 -#define Rxc_atol 2 -#define Rxc_rtol 3 -#define Rxc_maxsteps 4 -#define Rxc_hmin 5 -#define Rxc_hmax 6 -#define Rxc_hini 7 -#define Rxc_maxordn 8 -#define Rxc_maxords 9 -#define Rxc_covsInterpolation 10 -#define Rxc_addCov 11 -#define Rxc_returnType 12 -#define Rxc_sigma 13 -#define Rxc_sigmaDf 14 -#define Rxc_nCoresRV 15 -#define Rxc_sigmaIsChol 16 -#define Rxc_sigmaSeparation 17 -#define Rxc_sigmaXform 18 -#define Rxc_nDisplayProgress 19 -#define Rxc_amountUnits 20 -#define Rxc_timeUnits 21 -#define Rxc_addDosing 22 -#define Rxc_stateTrim 23 -#define Rxc_updateObject 24 -#define Rxc_omega 25 -#define Rxc_omegaDf 26 -#define Rxc_omegaIsChol 27 -#define Rxc_omegaSeparation 28 -#define Rxc_omegaXform 29 -#define Rxc_nSub 30 -#define Rxc_thetaMat 31 -#define Rxc_thetaDf 32 -#define Rxc_thetaIsChol 33 -#define Rxc_nStud 34 -#define Rxc_dfSub 35 -#define Rxc_dfObs 36 -#define Rxc_seed 37 -#define Rxc_nsim 38 -#define Rxc_minSS 39 -#define Rxc_maxSS 40 -#define Rxc_strictSS 41 -#define Rxc_infSSstep 42 -#define Rxc_istateReset 43 -#define Rxc_subsetNonmem 44 -#define Rxc_hmaxSd 45 -#define Rxc_maxAtolRtolFactor 46 -#define Rxc_from 47 -#define Rxc_to 48 -#define Rxc_by 49 -#define Rxc_length_out 50 -#define Rxc_iCov 51 -#define Rxc_keep 52 -#define Rxc_keepF 53 -#define Rxc_drop 54 -#define Rxc_warnDrop 55 -#define Rxc_omegaLower 56 -#define Rxc_omegaUpper 57 -#define Rxc_sigmaLower 58 -#define Rxc_sigmaUpper 59 -#define Rxc_thetaLower 60 -#define Rxc_thetaUpper 61 -#define Rxc_indLinPhiM 62 -#define Rxc_indLinPhiTol 63 -#define Rxc_indLinMatExpType 64 -#define Rxc_indLinMatExpOrder 65 -#define Rxc_idFactor 66 -#define Rxc_mxhnil 67 -#define Rxc_hmxi 68 -#define Rxc_warnIdSort 69 -#define Rxc_ssAtol 70 -#define Rxc_ssRtol 71 -#define Rxc_safeZero 72 -#define Rxc_sumType 73 -#define Rxc_prodType 74 -#define Rxc_sensType 75 -#define Rxc_linDiff 76 -#define Rxc_linDiffCentral 77 -#define Rxc_resample 78 -#define Rxc_resampleID 79 -#define Rxc_maxwhile 80 -#define Rxc_cores 81 -#define Rxc_atolSens 82 -#define Rxc_rtolSens 83 -#define Rxc_ssAtolSens 84 -#define Rxc_ssRtolSens 85 -#define Rxc_simVariability 86 -#define Rxc_nLlikAlloc 87 -#define Rxc_useStdPow 88 -#define Rxc_naTimeHandle 89 -#define Rxc_addlKeepsCov 90 -#define Rxc_addlDropSs 91 -#define Rxc_ssAtDoseTime 92 -#define Rxc_ss2cancelAllPending 93 -#define Rxc__zeros 94 +#include "rxode2parse_control.h" #endif // __rxode2_control_H__ diff --git a/inst/include/rxode2parse.h b/inst/include/rxode2parse.h index 153e1d734..bcd93d5ad 100644 --- a/inst/include/rxode2parse.h +++ b/inst/include/rxode2parse.h @@ -37,40 +37,8 @@ #include #include -#include "rxode2parse_control.h" +#include "rxode2_control.h" #include // for uint64_t rather than unsigned long long -#ifdef _isrxode2parse_ -#define max2( a , b ) ( (a) > (b) ? (a) : (b) ) -#define isSameTime(xout, xp) (fabs((xout)-(xp)) <= DBL_EPSILON*max2(fabs(xout),fabs(xp))) -// use ~dop853 definition of same time -#define isSameTimeDop(xout, xp) (0.1 * fabs((xout)-(xp)) <= fabs(xout) * 2.3E-16) -#define _linCmtParse _rxode2parse_linCmtParse -#define _rxode2_linCmtGen _rxode2parse_linCmtGen -#define rc_buf_read _rxode2parse_rc_buf_read -#define sIniTo _rxode2parse_sIniTo -#define sFree _rxode2parse_sFree -#define sFreeIni _rxode2parse_sFreeIni -#define sAppendN _rxode2parse_sAppendN -#define sAppend _rxode2parse_sAppend -#define sPrint _rxode2parse_sPrint -#define lineIni _rxode2parse_lineIni -#define lineFree _rxode2parse_lineFree -#define addLine _rxode2parse_addLine -#define curLineProp _rxode2parse_curLineProp -#define curLineType _rxode2parse_curLineType -#define doDot _rxode2parse_doDot -#define doDot2 _rxode2parse_doDot2 -#define _setSilentErr _rxode2parse__setSilentErr -#define _isRstudio2 _rxode2parse_isRstudio2 -#define setSilentErr _rxode2parse_setSilentErr -#define setRstudioPrint _rxode2parse_setRstudioPrint -#define getSilentErr _rxode2parse_getSilentErr -#define getRstudioPrint _rxode2parse_getRstudioPrint -#define RSprintf _rxode2parse_RSprintf -#define parseFree _rxode2parse_parseFree -#define parseFreeLast _rxode2parse_parseFreeLast -#define reset _rxode2parse_reset -#endif #include "rxode2parseStruct.h" #endif diff --git a/inst/include/rxode2parseConvertMethod.h b/inst/include/rxode2parseConvertMethod.h deleted file mode 100644 index d4617c446..000000000 --- a/inst/include/rxode2parseConvertMethod.h +++ /dev/null @@ -1,57 +0,0 @@ -#ifndef __rxode2parseConvertMethod_h__ -#define __rxode2parseConvertMethod_h__ -IntegerVector convertMethod(RObject method){ - IntegerVector oldEvid; - if (rxIsChar(method)){ - CharacterVector tmp = asCv(method, "method"); - oldEvid = IntegerVector(tmp.size()); - for (int jj = tmp.size(); jj--;){ - std::string cur = (as(tmp[jj])).substr(0,1); - // (1 = replace, 2 = add, 3 = multiply) - if (cur == "A" || cur == "a" || cur == "2"){ - oldEvid[jj] = 1; - } else if (cur == "m" || cur == "M" || cur == "3"){ - oldEvid[jj] = 6; - } else if (cur == "r" || cur == "R" || cur == "1"){ - oldEvid[jj] = 5; - } else { - stop(_("unknown method: '%s'"), (as(tmp[jj])).c_str()); - } - } - } else if (Rf_inherits(method, "factor")){ - IntegerVector tmp = asIv(method, "method"); - oldEvid = IntegerVector(tmp.size()); - CharacterVector lvl = tmp.attr("levels"); - IntegerVector trans(lvl.size()); - for (int jj = lvl.size(); jj--;){ - std::string cur = (as(lvl[jj])).substr(0,1); - if (cur == "A" || cur == "a" || cur == "2"){ - trans[jj] = 1; - } else if (cur == "m" || cur == "M" || cur == "3"){ - trans[jj] = 6; - } else if (cur == "r" || cur == "R" || cur == "1"){ - trans[jj] = 5; - } else { - stop(_("unknown method: '%s'"), (as(lvl[jj])).c_str()); - } - } - for (int jj = tmp.size(); jj--;){ - oldEvid[jj] = trans[tmp[jj]-1]; - } - } else if (rxIsNumInt(method)){ - IntegerVector tmp = as(method); - oldEvid = IntegerVector(tmp.size()); - for (int jj = tmp.size(); jj--;){ - // (1 = replace, 2 = add, 3 = multiply) - if (tmp[jj] == 1.){ - oldEvid[jj] = 5; - } else if (tmp[jj] == 2.){ - oldEvid[jj] = 1; - } else if (tmp[jj] == 3.){ - oldEvid[jj] = 6; - } - } - } - return oldEvid; -} -#endif diff --git a/inst/include/rxode2parseSbuf.h b/inst/include/rxode2parseSbuf.h index d65191f59..5a978739b 100644 --- a/inst/include/rxode2parseSbuf.h +++ b/inst/include/rxode2parseSbuf.h @@ -77,7 +77,6 @@ void addLine(vLines *sbb, const char *format, ...); void curLineProp(vLines *sbb, int propId); void curLineType(vLines *sbb, int propId); - void doDot(sbuf *out, char *buf); void doDot2(sbuf *sb, sbuf *sbDt, char *buf); diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index adfccd12f..b030e5edb 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -284,9 +284,9 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// etTransParse -List etTransParse(List inData, List mv, bool addCmt, bool dropUnits, bool allTimeVar, bool keepDosingOnly, Nullable combineDvid, CharacterVector keep, bool addlKeepsCov, bool addlDropSs, bool ssAtDoseTime); -RcppExport SEXP _rxode2_etTransParse(SEXP inDataSEXP, SEXP mvSEXP, SEXP addCmtSEXP, SEXP dropUnitsSEXP, SEXP allTimeVarSEXP, SEXP keepDosingOnlySEXP, SEXP combineDvidSEXP, SEXP keepSEXP, SEXP addlKeepsCovSEXP, SEXP addlDropSsSEXP, SEXP ssAtDoseTimeSEXP) { +// etTrans +List etTrans(List inData, List mv, bool addCmt, bool dropUnits, bool allTimeVar, bool keepDosingOnly, Nullable combineDvid, CharacterVector keep, bool addlKeepsCov, bool addlDropSs, bool ssAtDoseTime); +RcppExport SEXP _rxode2_etTrans(SEXP inDataSEXP, SEXP mvSEXP, SEXP addCmtSEXP, SEXP dropUnitsSEXP, SEXP allTimeVarSEXP, SEXP keepDosingOnlySEXP, SEXP combineDvidSEXP, SEXP keepSEXP, SEXP addlKeepsCovSEXP, SEXP addlDropSsSEXP, SEXP ssAtDoseTimeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -301,7 +301,7 @@ BEGIN_RCPP Rcpp::traits::input_parameter< bool >::type addlKeepsCov(addlKeepsCovSEXP); Rcpp::traits::input_parameter< bool >::type addlDropSs(addlDropSsSEXP); Rcpp::traits::input_parameter< bool >::type ssAtDoseTime(ssAtDoseTimeSEXP); - rcpp_result_gen = Rcpp::wrap(etTransParse(inData, mv, addCmt, dropUnits, allTimeVar, keepDosingOnly, combineDvid, keep, addlKeepsCov, addlDropSs, ssAtDoseTime)); + rcpp_result_gen = Rcpp::wrap(etTrans(inData, mv, addCmt, dropUnits, allTimeVar, keepDosingOnly, combineDvid, keep, addlKeepsCov, addlDropSs, ssAtDoseTime)); return rcpp_result_gen; END_RCPP } diff --git a/src/approx.c b/src/approx.c index 7cec2001e..0bde6bdd4 100644 --- a/src/approx.c +++ b/src/approx.c @@ -6,8 +6,8 @@ #include #include #include "../inst/include/rxode2.h" -#include -#include +#include "../inst/include/rxode2parseHandleEvid.h" +#include "../inst/include/rxode2parseGetTime.h" #define safe_zero(a) ((a) == 0 ? DBL_EPSILON : (a)) #define _as_zero(a) (fabs(a) < sqrt(DBL_EPSILON) ? 0.0 : a) diff --git a/src/cbindThetaOmega.cpp b/src/cbindThetaOmega.cpp index 37f7e2856..4375b0015 100644 --- a/src/cbindThetaOmega.cpp +++ b/src/cbindThetaOmega.cpp @@ -2,7 +2,7 @@ #define STRICT_R_HEADERS #include #include -#include +#include "../inst/include/rxode2parse.h" #ifdef ENABLE_NLS diff --git a/src/codegen.c b/src/codegen.c index 6c750b9f8..e083fd0e1 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -545,7 +545,7 @@ void writeSb(sbuf *sbb, FILE *fp){ extern SEXP _goodFuns; -SEXP _rxode2parse_codegen(SEXP c_file, SEXP prefix, SEXP libname, +SEXP _rxode2_codegen(SEXP c_file, SEXP prefix, SEXP libname, SEXP pMd5, SEXP timeId, SEXP mvLast, SEXP goodFuns){ _goodFuns = PROTECT(goodFuns); _rxode2parse_protected++; diff --git a/src/codegen.h b/src/codegen.h index 88968ae2a..c8045e77e 100644 --- a/src/codegen.h +++ b/src/codegen.h @@ -19,6 +19,7 @@ #define _(String) (String) #endif #include "../inst/include/rxode2parse.h" +#include "../inst/include/rxode2_control.h" #include "tran.h" #include "../inst/include/rxode2parseSbuf.h" @@ -261,7 +262,7 @@ static inline void printCModelVars(const char *prefix) { sAppend(&sbOut, "extern SEXP %smodel_vars(void){\n int pro=0;\n", prefix); sAppend(&sbOut, " SEXP _mv = PROTECT(_rxGetModelLib(\"%smodel_vars\"));pro++;\n", prefix); sAppendN(&sbOut, " if (!_rxIsCurrentC(_mv)){\n", 28); - sAppendN(&sbOut, " SEXP hash = PROTECT(allocVector(STRSXP, 1));pro++;\n", 58); + sAppendN(&sbOut, " SEXP hash = PROTECT(Rf_allocVector(STRSXP, 1));pro++;\n", 61); sAppend(&sbOut, "#define __doBuf__ snprintf(buf, __doBufN__, \"", _mv.o+1); int off=0; int off2 = 0; @@ -355,7 +356,7 @@ void writeSb(sbuf *sbb, FILE *fp); CHAR(STRING_ELT(libname, 1))); \ writeSb(&sbOut, fpIO); -SEXP _rxode2parse_codegen(SEXP c_file, SEXP prefix, SEXP libname, +SEXP _rxode2_codegen(SEXP c_file, SEXP prefix, SEXP libname, SEXP pMd5, SEXP timeId, SEXP mvLast, SEXP goodFuns); extern int fullPrint; diff --git a/src/cvPost.cpp b/src/cvPost.cpp index 3b6a2585c..249310575 100644 --- a/src/cvPost.cpp +++ b/src/cvPost.cpp @@ -8,18 +8,15 @@ #include #include "checkmate.h" #include -#include +#include "../inst/include/rxode2parse.h" #include "../inst/include/rxode2_as.h" extern "C"{ extern "C" SEXP chin(SEXP a, SEXP b); - - typedef int (*get_sexp_uniqueL_type)(SEXP s); - get_sexp_uniqueL_type get_sexp_uniqueL; typedef SEXP (*lotriMat_type) (SEXP, SEXP, SEXP); lotriMat_type lotriMat; - typedef SEXP (*asLotriMat_type) (SEXP, SEXP, SEXP); + typedef SEXP (*asLotriMat_type) (SEXP, SEXP, SEXP); asLotriMat_type asLotriMat; typedef SEXP (*lotriSep_type) (SEXP, SEXP, SEXP, SEXP, SEXP); lotriSep_type lotriSep; @@ -31,19 +28,6 @@ extern "C"{ isLotri_type isLotri; typedef SEXP (*lotriMaxNu_type) (SEXP); lotriMaxNu_type lotriMaxNu; - typedef SEXP (*rxSolveFreeSexp_t)(void); - rxSolveFreeSexp_t rxSolveFree; - typedef SEXP (*etTrans_t)(SEXP, SEXP, SEXP, SEXP, SEXP, - SEXP, SEXP, SEXP, SEXP, SEXP, - SEXP); - etTrans_t etTransSexp; - typedef void (*rxModelsAssignC_t)(const char* str, SEXP assign); - rxModelsAssignC_t rxModelsAssign; - typedef SEXP (*rxModelVars_SEXP_t)(SEXP); - rxModelVars_SEXP_t rxModelVars_; - typedef SEXP (*rxExpandNestingSexp_t)(SEXP, SEXP, SEXP); - rxExpandNestingSexp_t rxExpandNestingSexp; - typedef SEXP (*getArmaMat_t)(int type, int csim, rx_solve* rx); } List etTrans(List inData, const RObject &obj, bool addCmt=false, bool dropUnits=false, bool allTimeVar=false, @@ -57,39 +41,23 @@ SEXP nestingInfo_(SEXP omega, List data); List rxExpandNesting(const RObject& obj, List& nestingInfo, bool compile=false); -extern "C" SEXP _cbindOme(SEXP et_, SEXP mat_, SEXP n_); - -extern "C" SEXP _vecDF(SEXP cv, SEXP n_); - -typedef SEXP (*convertId_type)(SEXP x); - -bool convertId_assigned = false; -convertId_type convertId_; +List rxModelVars_(const RObject &obj); -extern Function loadNamespace; -extern bool rxode2parse_loaded; -extern Environment rxode2parse; +extern "C" int get_sexp_uniqueL( SEXP s ); +extern "C" SEXP _cbindOme(SEXP et_, SEXP mat_, SEXP n_); -SEXP assignConvertId(void) { - BEGIN_RCPP - if (!rxode2parse_loaded) { - rxode2parse = loadNamespace("rxode2parse"); - rxode2parse_loaded = true; - Function funPtrs = rxode2parse[".rxode2parseFunPtrs"]; - List ptr = as(funPtrs()); - convertId_ = (convertId_type)(R_ExternalPtrAddr(ptr[0])); - get_sexp_uniqueL = (get_sexp_uniqueL_type)(R_ExternalPtrAddr(ptr[6])); - } - END_RCPP -} +extern "C" SEXP _vecDF(SEXP cv, SEXP n_); +SEXP convertId_(SEXP x); SEXP rxRmvnSEXP(SEXP nS, SEXP muS, SEXP sigmaS, SEXP lowerS, SEXP upperS, SEXP ncoresS, SEXP isCholS, SEXP keepNamesS, SEXP aS, SEXP tolS, SEXP nlTolS, SEXP nlMaxiterS); +void rxModelsAssign(std::string str, SEXP assign); +LogicalVector rxSolveFree(); bool gotLotriMat=false; @@ -1131,10 +1099,6 @@ int factor2( IntegerVector col, IntegerVector id) { SEXP nestingInfoSingle_(SEXP col, IntegerVector id) { - if (!convertId_assigned) { - assignConvertId(); - convertId_assigned=true; - } SEXP f2 = PROTECT(convertId_(col)); int l1 = factor2(f2, id); int lid = Rf_length(Rf_getAttrib(id, R_LevelsSymbol)); @@ -1174,10 +1138,6 @@ SEXP nestingInfoSingle_(SEXP col, IntegerVector id) { //[[Rcpp::export]] SEXP nestingInfo_(SEXP omega, List data) { // Might need to clone... - if (!convertId_assigned) { - assignConvertId(); - convertId_assigned=true; - } int pro = 0; CharacterVector lName = data.names(); int wid = -1; diff --git a/src/et.cpp b/src/et.cpp index 83d6df173..b438d3078 100644 --- a/src/et.cpp +++ b/src/et.cpp @@ -5,10 +5,10 @@ #include #include #include "timsort.h" -#include +#include "../inst/include/rxode2parse.h" extern "C" rx_solve rx_global; extern "C" rx_solving_options op_global; -#include +#include "../inst/include/rxode2parseHandleEvid.h" #include "checkmate.h" #define SORT gfx::timsort @@ -48,7 +48,7 @@ Environment rxode2env (); Function getRxFn(std::string name); Function getForder(); -bool useForder(); +extern "C" int useForder(void); RObject evCur; RObject curSolve; @@ -948,7 +948,8 @@ CharacterVector deparseUnit(NumericVector nv){ } } -#include + +IntegerVector convertMethod(RObject method); List etImportEventTable(List inData, bool warnings = true){ CharacterVector lName0 = asCv(inData.attr("names"), "names"); diff --git a/src/etTran.cpp b/src/etTran.cpp index 66ce78400..0b297e034 100644 --- a/src/etTran.cpp +++ b/src/etTran.cpp @@ -36,6 +36,8 @@ using namespace Rcpp; extern int fastFactorDataHasNa; +SEXP convertId_(SEXP x); + static inline bool rxIsNumInt(RObject obj) { int type = obj.sexp_type(); if (type == REALSXP || type == 13) { @@ -169,7 +171,6 @@ IntegerVector convertDvid_(SEXP inCmt, int maxDvid=0){ } return id; } -#define getForder _rxode2parse_getForder extern "C" SEXP getForder(void) { if (!getForder_b){ Function fn = getRxFn(".getDTEnv"); @@ -198,13 +199,11 @@ Function getChin() { return b["%in%"]; } -#define chin _rxode2parse_chin extern "C" SEXP chin(SEXP x, SEXP table) { Function chin_ = getChin(); return chin_(x, table); } -#define useForder _rxode2parse_useForder extern "C" int useForder(void){ return (int)(getForder_b); } @@ -436,10 +435,62 @@ bool rxSetIni0(bool ini0 = true) { return _ini0; } -#include "../inst/include/rxode2parseConvertMethod.h" +IntegerVector convertMethod(RObject method) { + IntegerVector oldEvid; + if (rxIsChar(method)){ + CharacterVector tmp = asCv(method, "method"); + oldEvid = IntegerVector(tmp.size()); + for (int jj = tmp.size(); jj--;){ + std::string cur = (as(tmp[jj])).substr(0,1); + // (1 = replace, 2 = add, 3 = multiply) + if (cur == "A" || cur == "a" || cur == "2"){ + oldEvid[jj] = 1; + } else if (cur == "m" || cur == "M" || cur == "3"){ + oldEvid[jj] = 6; + } else if (cur == "r" || cur == "R" || cur == "1"){ + oldEvid[jj] = 5; + } else { + stop(_("unknown method: '%s'"), (as(tmp[jj])).c_str()); + } + } + } else if (Rf_inherits(method, "factor")){ + IntegerVector tmp = asIv(method, "method"); + oldEvid = IntegerVector(tmp.size()); + CharacterVector lvl = tmp.attr("levels"); + IntegerVector trans(lvl.size()); + for (int jj = lvl.size(); jj--;){ + std::string cur = (as(lvl[jj])).substr(0,1); + if (cur == "A" || cur == "a" || cur == "2"){ + trans[jj] = 1; + } else if (cur == "m" || cur == "M" || cur == "3"){ + trans[jj] = 6; + } else if (cur == "r" || cur == "R" || cur == "1"){ + trans[jj] = 5; + } else { + stop(_("unknown method: '%s'"), (as(lvl[jj])).c_str()); + } + } + for (int jj = tmp.size(); jj--;){ + oldEvid[jj] = trans[tmp[jj]-1]; + } + } else if (rxIsNumInt(method)){ + IntegerVector tmp = as(method); + oldEvid = IntegerVector(tmp.size()); + for (int jj = tmp.size(); jj--;){ + // (1 = replace, 2 = add, 3 = multiply) + if (tmp[jj] == 1.){ + oldEvid[jj] = 5; + } else if (tmp[jj] == 2.){ + oldEvid[jj] = 1; + } else if (tmp[jj] == 3.){ + oldEvid[jj] = 6; + } + } + } + return oldEvid; +} extern "C" SEXP _rxode2parse_convertId_(SEXP id); -#define convertId_ _rxode2parse_convertId_ bool warnedNeg=false; bool evid2isObs=true; @@ -523,13 +574,13 @@ RObject etTranGetAttrKeep(SEXP in) { //' //' @export //[[Rcpp::export]] -List etTransParse(List inData, List mv, bool addCmt=false, - bool dropUnits=false, bool allTimeVar=false, - bool keepDosingOnly=false, Nullable combineDvid=R_NilValue, - CharacterVector keep = CharacterVector(0), - bool addlKeepsCov=false, - bool addlDropSs = true, - bool ssAtDoseTime=true) { +List etTrans(List inData, List mv, bool addCmt=false, + bool dropUnits=false, bool allTimeVar=false, + bool keepDosingOnly=false, Nullable combineDvid=R_NilValue, + CharacterVector keep = CharacterVector(0), + bool addlKeepsCov=false, + bool addlDropSs = true, + bool ssAtDoseTime=true) { #ifdef rxSolveT clock_t _lastT0 = clock(); #endif @@ -791,7 +842,7 @@ List etTransParse(List inData, List mv, bool addCmt=false, List newInData = clone(inData); Function convDate = rx[".convertExtra"]; newInData = convDate(newInData); - return etTransParse(newInData, mv, addCmt, dropUnits, allTimeVar, keepDosingOnly, combineDvid); + return etTrans(newInData, mv, addCmt, dropUnits, allTimeVar, keepDosingOnly, combineDvid); } size_t resSize = inTime.size()+256; std::vector id; diff --git a/src/genModelVars.c b/src/genModelVars.c index 9d0b9b306..07508227c 100644 --- a/src/genModelVars.c +++ b/src/genModelVars.c @@ -9,45 +9,45 @@ SEXP generateModelVars(void) { calcNextra(); int pro = 0; - SEXP lst = PROTECT(allocVector(VECSXP, 21));pro++; - SEXP names = PROTECT(allocVector(STRSXP, 21));pro++; + SEXP lst = PROTECT(Rf_allocVector(VECSXP, 21));pro++; + SEXP names = PROTECT(Rf_allocVector(STRSXP, 21));pro++; - SEXP sNeedSort = PROTECT(allocVector(INTSXP,1));pro++; + SEXP sNeedSort = PROTECT(Rf_allocVector(INTSXP,1));pro++; int *iNeedSort = INTEGER(sNeedSort); iNeedSort[0] = needSort; SEXP sLinCmt =PROTECT(calcSLinCmt());pro++; - SEXP sMtime = PROTECT(allocVector(INTSXP,1));pro++; + SEXP sMtime = PROTECT(Rf_allocVector(INTSXP,1));pro++; int *iMtime = INTEGER(sMtime); iMtime[0] = (int)nmtime; - SEXP tran = PROTECT(allocVector(STRSXP, 22));pro++; - SEXP trann = PROTECT(allocVector(STRSXP, 22));pro++; + SEXP tran = PROTECT(Rf_allocVector(STRSXP, 22));pro++; + SEXP trann = PROTECT(Rf_allocVector(STRSXP, 22));pro++; - SEXP state = PROTECT(allocVector(STRSXP,tb.statei-tb.nExtra));pro++; - SEXP stateRmS = PROTECT(allocVector(INTSXP,tb.statei-tb.nExtra));pro++; + SEXP state = PROTECT(Rf_allocVector(STRSXP,tb.statei-tb.nExtra));pro++; + SEXP stateRmS = PROTECT(Rf_allocVector(INTSXP,tb.statei-tb.nExtra));pro++; int *stateRm = INTEGER(stateRmS); - SEXP extraState = PROTECT(allocVector(STRSXP,tb.nExtra));pro++; - SEXP sens = PROTECT(allocVector(STRSXP,tb.sensi));pro++; - SEXP normState= PROTECT(allocVector(STRSXP,tb.statei-tb.sensi-tb.nExtra));pro++; + SEXP extraState = PROTECT(Rf_allocVector(STRSXP,tb.nExtra));pro++; + SEXP sens = PROTECT(Rf_allocVector(STRSXP,tb.sensi));pro++; + SEXP normState= PROTECT(Rf_allocVector(STRSXP,tb.statei-tb.sensi-tb.nExtra));pro++; populateStateVectors(state, sens, normState, stateRm, extraState); - SEXP dfdy = PROTECT(allocVector(STRSXP,tb.ndfdy));pro++; + SEXP dfdy = PROTECT(Rf_allocVector(STRSXP,tb.ndfdy));pro++; populateDfdy(dfdy); - SEXP params = PROTECT(allocVector(STRSXP, tb.pi));pro++; - SEXP lhs = PROTECT(allocVector(STRSXP, tb.li));pro++; - SEXP slhs = PROTECT(allocVector(STRSXP, tb.sli));pro++; + SEXP params = PROTECT(Rf_allocVector(STRSXP, tb.pi));pro++; + SEXP lhs = PROTECT(Rf_allocVector(STRSXP, tb.li));pro++; + SEXP slhs = PROTECT(Rf_allocVector(STRSXP, tb.sli));pro++; SEXP version = PROTECT(calcVersionInfo());pro++; SEXP ini = PROTECT(calcIniVals()); pro++; - SEXP model = PROTECT(allocVector(STRSXP,2));pro++; - SEXP modeln = PROTECT(allocVector(STRSXP,2));pro++; + SEXP model = PROTECT(Rf_allocVector(STRSXP,2));pro++; + SEXP modeln = PROTECT(Rf_allocVector(STRSXP,2));pro++; populateParamsLhsSlhs(params, lhs, slhs); @@ -95,7 +95,7 @@ SEXP generateModelVars(void) { SET_VECTOR_ELT(lst, 12,sMtime); SET_STRING_ELT(names, 13, mkChar("extraCmt")); - SEXP sExtraCmt = PROTECT(allocVector(INTSXP,1));pro++; + SEXP sExtraCmt = PROTECT(Rf_allocVector(INTSXP,1));pro++; INTEGER(sExtraCmt)[0] = extraCmt; SET_VECTOR_ELT(lst, 13, sExtraCmt); @@ -103,12 +103,12 @@ SEXP generateModelVars(void) { SET_VECTOR_ELT(lst, 14, extraState); SET_STRING_ELT(names, 15, mkChar("dvid")); - SEXP sDvid = PROTECT(allocVector(INTSXP,tb.dvidn));pro++; + SEXP sDvid = PROTECT(Rf_allocVector(INTSXP,tb.dvidn));pro++; for (int i = 0; i < tb.dvidn; i++) INTEGER(sDvid)[i]=tb.dvid[i]; SET_VECTOR_ELT(lst, 15, sDvid); SET_STRING_ELT(names, 16, mkChar("indLin")); - SEXP matLst = PROTECT(allocVector(VECSXP, 0));pro++; + SEXP matLst = PROTECT(Rf_allocVector(VECSXP, 0));pro++; SET_VECTOR_ELT(lst, 16, matLst); SET_STRING_ELT(names, 17, mkChar("flags")); @@ -117,7 +117,7 @@ SEXP generateModelVars(void) { SET_STRING_ELT(names, 18, mkChar("slhs")); SET_VECTOR_ELT(lst, 18, slhs); - SEXP alagVarSexp = PROTECT(allocVector(INTSXP, tb.alagn));pro++; + SEXP alagVarSexp = PROTECT(Rf_allocVector(INTSXP, tb.alagn));pro++; int *alagVar = INTEGER(alagVarSexp); for (int i = 0; i < tb.alagn; ++i) { alagVar[i] = tb.alag[i]; @@ -229,7 +229,7 @@ SEXP generateModelVars(void) { setAttrib(tran, R_NamesSymbol, trann); setAttrib(lst, R_NamesSymbol, names); setAttrib(model, R_NamesSymbol, modeln); - SEXP cls = PROTECT(allocVector(STRSXP, 1));pro++; + SEXP cls = PROTECT(Rf_allocVector(STRSXP, 1));pro++; SET_STRING_ELT(cls, 0, mkChar("rxModelVars")); classgets(lst, cls); diff --git a/src/genModelVars.h b/src/genModelVars.h index 034151418..d50950468 100644 --- a/src/genModelVars.h +++ b/src/genModelVars.h @@ -25,7 +25,7 @@ #include "../inst/include/rxode2parseVer.h" static inline SEXP calcSLinCmt(void) { - SEXP sLinCmt = PROTECT(allocVector(INTSXP,12)); + SEXP sLinCmt = PROTECT(Rf_allocVector(INTSXP,12)); INTEGER(sLinCmt)[0] = tb.ncmt; INTEGER(sLinCmt)[1] = tb.hasKa; INTEGER(sLinCmt)[2] = tb.linB; @@ -38,7 +38,7 @@ static inline SEXP calcSLinCmt(void) { INTEGER(sLinCmt)[10]= tb.thread; INTEGER(sLinCmt)[11]= tb.nLlik; - SEXP sLinCmtN = PROTECT(allocVector(STRSXP, 12)); + SEXP sLinCmtN = PROTECT(Rf_allocVector(STRSXP, 12)); SET_STRING_ELT(sLinCmtN, 0, mkChar("ncmt")); SET_STRING_ELT(sLinCmtN, 1, mkChar("ka")); SET_STRING_ELT(sLinCmtN, 2, mkChar("linB")); @@ -57,8 +57,8 @@ static inline SEXP calcSLinCmt(void) { } static inline SEXP calcVersionInfo(void) { - SEXP version = PROTECT(allocVector(STRSXP, 3)); - SEXP versionn = PROTECT(allocVector(STRSXP, 3)); + SEXP version = PROTECT(Rf_allocVector(STRSXP, 3)); + SEXP versionn = PROTECT(Rf_allocVector(STRSXP, 3)); SET_STRING_ELT(versionn,0,mkChar("version")); SET_STRING_ELT(versionn,1,mkChar("repo")); @@ -147,8 +147,8 @@ static inline void calcExtracmt(void) { static inline SEXP calcIniVals(void) { int pro=0; - SEXP inin = PROTECT(allocVector(STRSXP, tb.isPi + tb.ini_i)); pro++; - SEXP ini = PROTECT(allocVector(REALSXP, tb.isPi + tb.ini_i)); pro++; + SEXP inin = PROTECT(Rf_allocVector(STRSXP, tb.isPi + tb.ini_i)); pro++; + SEXP ini = PROTECT(Rf_allocVector(REALSXP, tb.isPi + tb.ini_i)); pro++; char *buf; for (int i=tb.isPi + tb.ini_i;i--;) REAL(ini)[i] = NA_REAL; int ini_i=0; @@ -169,8 +169,8 @@ static inline SEXP calcIniVals(void) { SET_STRING_ELT(inin,ini_i,mkChar("pi")); REAL(ini)[ini_i++] = M_PI; } else if (redo){ - inin = PROTECT(allocVector(STRSXP, tb.ini_i));pro++; - ini = PROTECT(allocVector(REALSXP, tb.ini_i));pro++; + inin = PROTECT(Rf_allocVector(STRSXP, tb.ini_i));pro++; + ini = PROTECT(Rf_allocVector(REALSXP, tb.ini_i));pro++; for (int i = tb.ini_i; i--;) REAL(ini)[i] = NA_REAL; ini_i=0; for (int i = 0; i < NV; i++){ diff --git a/src/handle_evid.c b/src/handle_evid.c index 60cb6e239..a7d6d2bf5 100644 --- a/src/handle_evid.c +++ b/src/handle_evid.c @@ -15,7 +15,7 @@ #define _(String) (String) #endif #include "../inst/include/rxode2.h" -#include +#include "../inst/include/rxode2parseHandleEvid.h" int handle_evidL(int evid, double *yp, double xout, int id, rx_solving_options_ind *ind) { diff --git a/src/init.c b/src/init.c index 3a4aa957a..11e0d5b1e 100644 --- a/src/init.c +++ b/src/init.c @@ -10,7 +10,7 @@ #define __DOINIT__ #include "cbindThetaOmega.h" #include "../inst/include/rxode2.h" -#include +#include "../inst/include/rxode2parseGetTime.h" SEXP _rxHasOpenMp(void); @@ -288,14 +288,6 @@ typedef SEXP (*isLotri_type) (SEXP); typedef SEXP (*lotriMaxNu_type) (SEXP); typedef SEXP (*rxSolveFreeSexp_t)(void); extern void setZeroMatrix(int which); -typedef SEXP (*etTrans_t)(SEXP, SEXP, SEXP, SEXP, SEXP, - SEXP, SEXP, SEXP, SEXP, SEXP, - SEXP); -typedef void (*rxModelsAssignC_t)(const char* str, SEXP assign); -typedef SEXP (*rxModelVars_SEXP_t)(SEXP); -typedef SEXP (*rxExpandNestingSexp_t)(SEXP, SEXP, SEXP); -typedef SEXP (*chin_t)(SEXP x, SEXP table); - extern rx_solve rx_global; extern rx_solving_options op_global; extern void setZeroMatrix(int which); diff --git a/src/lincmt.c b/src/lincmt.c index 2baaa7201..af30b7b4a 100644 --- a/src/lincmt.c +++ b/src/lincmt.c @@ -7,36 +7,35 @@ #include #include -#define op_global _rxode2parse_op_global -#define rx_global _rxode2parse_rx_global -#define AMT _rxode2parse_AMT -#define LAG _rxode2parse_LAG -#define RATE _rxode2parse_RATE -#define DUR _rxode2parse_DUR -#define calc_mtime _rxode2parse_calc_mtime -#define getTime_ _rxode2parse_getTime_ -#define getTime _rxode2parse_getTime -#define _locateTimeIndex _rxode2parse_locateTimeIndex +#define max2( a , b ) ( (a) > (b) ? (a) : (b) ) +#define isSameTime(xout, xp) (fabs((xout)-(xp)) <= DBL_EPSILON*max2(fabs(xout),fabs(xp))) + #include "../inst/include/rxode2parse.h" -#define _calcDerived _rxode2parse_calcDerived -extern rx_solving_options _rxode2parse_op_global; -extern rx_solve _rxode2parse_rx_global; +extern rx_solve rx_global; +extern rx_solving_options op_global; +extern t_F AMT; +extern t_LAG LAG; +extern t_RATE RATE; +extern t_DUR DUR; +extern t_calc_mtime calc_mtime; + +extern t_ME ME; +extern t_IndF IndF; +extern void RSprintf(const char *format, ...); + +extern int _locateTimeIndex(double obs_time, rx_solving_options_ind *ind); #include "../inst/include/rxode2parse.h" #include "../inst/include/rxode2parseHandleEvid.h" #include "../inst/include/rxode2parseGetTime.h" -extern t_locateTimeIndex _rxode2parse_locateTimeIndex; #define safe_zero(a) ((a) == 0 ? DBL_EPSILON : (a)) #define _as_zero(a) (fabs(a) < sqrt(DBL_EPSILON) ? 0.0 : a) #define _as_dbleps(a) (fabs(a) < sqrt(DBL_EPSILON) ? ((a) < 0 ? -sqrt(DBL_EPSILON) : sqrt(DBL_EPSILON)) : a) -void _rxode2parse_unprotect(void); - - #ifdef ENABLE_NLS #include #define _(String) dgettext ("rxode2parse", String) @@ -1629,7 +1628,6 @@ SEXP toReal(SEXP in){ UNPROTECT(1); return ret; } - _rxode2parse_unprotect(); Rf_errorcall(R_NilValue, _("not an integer/real")); return R_NilValue; } @@ -1648,59 +1646,58 @@ SEXP derived1(int trans, SEXP inp, double dig) { if (lenP == 1){ lenOut = lenV; } else if (lenV != 1){ - _rxode2parse_unprotect(); Rf_errorcall(R_NilValue, _("The dimensions of the parameters must match")); } } // vc, kel, vss, cl, thalf, alpha, A, fracA - SEXP ret = PROTECT(allocVector(VECSXP, 8)); pro++; - SEXP retN = PROTECT(allocVector(STRSXP, 8)); pro++; + SEXP ret = PROTECT(Rf_allocVector(VECSXP, 8)); pro++; + SEXP retN = PROTECT(Rf_allocVector(STRSXP, 8)); pro++; SET_STRING_ELT(retN,0,mkChar("vc")); - SEXP vcS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vcS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vc = REAL(vcS); SET_VECTOR_ELT(ret, 0, vcS); SET_STRING_ELT(retN,1,mkChar("kel")); - SEXP kelS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP kelS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *kel = REAL(kelS); SET_VECTOR_ELT(ret, 1, kelS); SET_STRING_ELT(retN,2,mkChar("vss")); - SEXP vssS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vssS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vss = REAL(vssS); SET_VECTOR_ELT(ret, 2, vssS); SET_STRING_ELT(retN,3,mkChar("cl")); - SEXP clS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP clS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *cl = REAL(clS); SET_VECTOR_ELT(ret, 3, clS); SET_STRING_ELT(retN,4,mkChar("t12alpha")); - SEXP thalfS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP thalfS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *thalf = REAL(thalfS); SET_VECTOR_ELT(ret, 4, thalfS); SET_STRING_ELT(retN,5,mkChar("alpha")); - SEXP alphaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP alphaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *alpha = REAL(alphaS); SET_VECTOR_ELT(ret, 5, alphaS); SET_STRING_ELT(retN,6,mkChar("A")); - SEXP AS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP AS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *A = REAL(AS); SET_VECTOR_ELT(ret, 6, AS); SET_STRING_ELT(retN,7,mkChar("fracA")); - SEXP fracAS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP fracAS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *fracA = REAL(fracAS); SET_VECTOR_ELT(ret, 7, fracAS); - SEXP sexp_class = PROTECT(allocVector(STRSXP, 1)); pro++; + SEXP sexp_class = PROTECT(Rf_allocVector(STRSXP, 1)); pro++; SET_STRING_ELT(sexp_class,0,mkChar("data.frame")); setAttrib(ret, R_ClassSymbol, sexp_class); - SEXP sexp_rownames = PROTECT(allocVector(INTSXP,2)); pro++; + SEXP sexp_rownames = PROTECT(Rf_allocVector(INTSXP,2)); pro++; INTEGER(sexp_rownames)[0] = NA_INTEGER; INTEGER(sexp_rownames)[1] = -lenOut; setAttrib(ret, R_RowNamesSymbol, sexp_rownames); @@ -1759,100 +1756,99 @@ SEXP derived2(int trans, SEXP inp, double dig) { (lenP2 != 1 && lenP2 != lenOut) || (lenP3 != 1 && lenP3 != lenOut) || (lenV != 1 && lenV != lenOut)) { - _rxode2parse_unprotect(); Rf_errorcall(R_NilValue, _("The dimensions of the parameters must match")); } } // vc, kel, k12, k21, vp, vss, cl, q, thalfAlpha, thalfBeta, // alpha, beta, A, B, fracA, fracB - SEXP ret = PROTECT(allocVector(VECSXP, 16)); pro++; - SEXP retN = PROTECT(allocVector(STRSXP, 16)); pro++; + SEXP ret = PROTECT(Rf_allocVector(VECSXP, 16)); pro++; + SEXP retN = PROTECT(Rf_allocVector(STRSXP, 16)); pro++; SET_STRING_ELT(retN,0,mkChar("vc")); - SEXP vcS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vcS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vc = REAL(vcS); SET_VECTOR_ELT(ret, 0, vcS); SET_STRING_ELT(retN,1,mkChar("kel")); - SEXP kelS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP kelS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *kel = REAL(kelS); SET_VECTOR_ELT(ret, 1, kelS); SET_STRING_ELT(retN,2,mkChar("k12")); - SEXP k12S = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP k12S = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *k12 = REAL(k12S); SET_VECTOR_ELT(ret, 2, k12S); SET_STRING_ELT(retN,3,mkChar("k21")); - SEXP k21S = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP k21S = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *k21 = REAL(k21S); SET_VECTOR_ELT(ret, 3, k21S); SET_STRING_ELT(retN,4,mkChar("vp")); - SEXP vpS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vpS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vp = REAL(vpS); SET_VECTOR_ELT(ret, 4, vpS); SET_STRING_ELT(retN,5,mkChar("vss")); - SEXP vssS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vssS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vss = REAL(vssS); SET_VECTOR_ELT(ret, 5, vssS); SET_STRING_ELT(retN,6,mkChar("cl")); - SEXP clS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP clS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *cl = REAL(clS); SET_VECTOR_ELT(ret, 6, clS); SET_STRING_ELT(retN,7,mkChar("q")); - SEXP qS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP qS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *q = REAL(qS); SET_VECTOR_ELT(ret, 7, qS); SET_STRING_ELT(retN,8,mkChar("t12alpha")); - SEXP thalfAlphaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP thalfAlphaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *thalfAlpha = REAL(thalfAlphaS); SET_VECTOR_ELT(ret, 8, thalfAlphaS); SET_STRING_ELT(retN,9,mkChar("t12beta")); - SEXP thalfBetaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP thalfBetaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *thalfBeta = REAL(thalfBetaS); SET_VECTOR_ELT(ret, 9, thalfBetaS); SET_STRING_ELT(retN,10,mkChar("alpha")); - SEXP alphaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP alphaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *alpha = REAL(alphaS); SET_VECTOR_ELT(ret, 10, alphaS); SET_STRING_ELT(retN,11,mkChar("beta")); - SEXP betaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP betaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *beta = REAL(betaS); SET_VECTOR_ELT(ret, 11, betaS); SET_STRING_ELT(retN,12,mkChar("A")); - SEXP AS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP AS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *A = REAL(AS); SET_VECTOR_ELT(ret, 12, AS); SET_STRING_ELT(retN,13,mkChar("B")); - SEXP BS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP BS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *B = REAL(BS); SET_VECTOR_ELT(ret, 13, BS); SET_STRING_ELT(retN,14,mkChar("fracA")); - SEXP fracAS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP fracAS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *fracA = REAL(fracAS); SET_VECTOR_ELT(ret, 14, fracAS); SET_STRING_ELT(retN,15,mkChar("fracB")); - SEXP fracBS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP fracBS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *fracB = REAL(fracBS); SET_VECTOR_ELT(ret, 15, fracBS); - SEXP sexp_class = PROTECT(allocVector(STRSXP, 1)); pro++; + SEXP sexp_class = PROTECT(Rf_allocVector(STRSXP, 1)); pro++; SET_STRING_ELT(sexp_class,0,mkChar("data.frame")); setAttrib(ret, R_ClassSymbol, sexp_class); - SEXP sexp_rownames = PROTECT(allocVector(INTSXP,2)); pro++; + SEXP sexp_rownames = PROTECT(Rf_allocVector(INTSXP,2)); pro++; INTEGER(sexp_rownames)[0] = NA_INTEGER; INTEGER(sexp_rownames)[1] = -lenOut; setAttrib(ret, R_RowNamesSymbol, sexp_rownames); @@ -1932,141 +1928,140 @@ SEXP derived3(int trans, SEXP inp, double dig) { (lenP4 != 1 && lenP4 != lenOut) || (lenP5 != 1 && lenP5 != lenOut) || (lenV != 1 && lenV != lenOut)) { - _rxode2parse_unprotect(); Rf_errorcall(R_NilValue, _("The dimensions of the parameters must match")); } } // vc, kel, k12, k21, vp, vss, cl, q, thalfAlpha, thalfBeta, // alpha, beta, A, B, fracA, fracB - SEXP ret = PROTECT(allocVector(VECSXP, 24)); pro++; - SEXP retN = PROTECT(allocVector(STRSXP, 24)); pro++; + SEXP ret = PROTECT(Rf_allocVector(VECSXP, 24)); pro++; + SEXP retN = PROTECT(Rf_allocVector(STRSXP, 24)); pro++; SET_STRING_ELT(retN,0,mkChar("vc")); - SEXP vcS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vcS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vc = REAL(vcS); SET_VECTOR_ELT(ret, 0, vcS); SET_STRING_ELT(retN,1,mkChar("kel")); - SEXP kelS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP kelS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *kel = REAL(kelS); SET_VECTOR_ELT(ret, 1, kelS); SET_STRING_ELT(retN,2,mkChar("k12")); - SEXP k12S = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP k12S = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *k12 = REAL(k12S); SET_VECTOR_ELT(ret, 2, k12S); SET_STRING_ELT(retN,3,mkChar("k21")); - SEXP k21S = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP k21S = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *k21 = REAL(k21S); SET_VECTOR_ELT(ret, 3, k21S); SET_STRING_ELT(retN,4,mkChar("k13")); - SEXP k13S = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP k13S = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *k13 = REAL(k13S); SET_VECTOR_ELT(ret, 4, k13S); SET_STRING_ELT(retN,5,mkChar("k31")); - SEXP k31S = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP k31S = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *k31 = REAL(k31S); SET_VECTOR_ELT(ret, 5, k31S); SET_STRING_ELT(retN,6,mkChar("vp")); - SEXP vpS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vpS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vp = REAL(vpS); SET_VECTOR_ELT(ret, 6, vpS); SET_STRING_ELT(retN,7,mkChar("vp2")); - SEXP vp2S = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vp2S = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vp2 = REAL(vp2S); SET_VECTOR_ELT(ret, 7, vp2S); SET_STRING_ELT(retN,8,mkChar("vss")); - SEXP vssS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP vssS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *vss = REAL(vssS); SET_VECTOR_ELT(ret, 8, vssS); SET_STRING_ELT(retN,9,mkChar("cl")); - SEXP clS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP clS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *cl = REAL(clS); SET_VECTOR_ELT(ret, 9, clS); SET_STRING_ELT(retN,10,mkChar("q")); - SEXP qS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP qS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *q = REAL(qS); SET_VECTOR_ELT(ret, 10, qS); SET_STRING_ELT(retN,11,mkChar("q2")); - SEXP q2S = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP q2S = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *q2 = REAL(q2S); SET_VECTOR_ELT(ret, 11, q2S); SET_STRING_ELT(retN,12,mkChar("t12alpha")); - SEXP thalfAlphaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP thalfAlphaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *thalfAlpha = REAL(thalfAlphaS); SET_VECTOR_ELT(ret, 12, thalfAlphaS); SET_STRING_ELT(retN,13,mkChar("t12beta")); - SEXP thalfBetaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP thalfBetaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *thalfBeta = REAL(thalfBetaS); SET_VECTOR_ELT(ret, 13, thalfBetaS); SET_STRING_ELT(retN,14,mkChar("t12gamma")); - SEXP thalfGammaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP thalfGammaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *thalfGamma = REAL(thalfGammaS); SET_VECTOR_ELT(ret, 14, thalfGammaS); SET_STRING_ELT(retN,15,mkChar("alpha")); - SEXP alphaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP alphaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *alpha = REAL(alphaS); SET_VECTOR_ELT(ret, 15, alphaS); SET_STRING_ELT(retN,16,mkChar("beta")); - SEXP betaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP betaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *beta = REAL(betaS); SET_VECTOR_ELT(ret, 16, betaS); SET_STRING_ELT(retN,17,mkChar("gamma")); - SEXP gammaS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP gammaS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *gamma = REAL(gammaS); SET_VECTOR_ELT(ret, 17, gammaS); SET_STRING_ELT(retN,18,mkChar("A")); - SEXP AS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP AS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *A = REAL(AS); SET_VECTOR_ELT(ret, 18, AS); SET_STRING_ELT(retN,19,mkChar("B")); - SEXP BS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP BS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *B = REAL(BS); SET_VECTOR_ELT(ret, 19, BS); SET_STRING_ELT(retN,20,mkChar("C")); - SEXP CS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP CS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *C = REAL(CS); SET_VECTOR_ELT(ret, 20, CS); SET_STRING_ELT(retN,21,mkChar("fracA")); - SEXP fracAS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP fracAS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *fracA = REAL(fracAS); SET_VECTOR_ELT(ret, 21, fracAS); SET_STRING_ELT(retN,22,mkChar("fracB")); - SEXP fracBS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP fracBS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *fracB = REAL(fracBS); SET_VECTOR_ELT(ret, 22, fracBS); SET_STRING_ELT(retN,23,mkChar("fracC")); - SEXP fracCS = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP fracCS = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; double *fracC = REAL(fracCS); SET_VECTOR_ELT(ret, 23, fracCS); - SEXP sexp_class = PROTECT(allocVector(STRSXP, 1)); pro++; + SEXP sexp_class = PROTECT(Rf_allocVector(STRSXP, 1)); pro++; SET_STRING_ELT(sexp_class,0,mkChar("data.frame")); setAttrib(ret, R_ClassSymbol, sexp_class); - SEXP sexp_rownames = PROTECT(allocVector(INTSXP,2)); pro++; + SEXP sexp_rownames = PROTECT(Rf_allocVector(INTSXP,2)); pro++; INTEGER(sexp_rownames)[0] = NA_INTEGER; INTEGER(sexp_rownames)[1] = -lenOut; setAttrib(ret, R_RowNamesSymbol, sexp_rownames); diff --git a/src/lincmtB.cpp b/src/lincmtB.cpp index a7331d213..70559b4eb 100644 --- a/src/lincmtB.cpp +++ b/src/lincmtB.cpp @@ -15,36 +15,19 @@ #endif #include +#include "../inst/include/rxode2parse.h" -#define op_global _rxode2parse_op_global -#define rx_global _rxode2parse_rx_global -#define AMT _rxode2parse_AMT -#define LAG _rxode2parse_LAG -#define RATE _rxode2parse_RATE -#define DUR _rxode2parse_DUR -#define calc_mtime _rxode2parse_calc_mtime -#define getTime_ _rxode2parse_getTime_ -#define getTime _rxode2parse_getTime -#define _locateTimeIndex _rxode2parse_locateTimeIndex +extern "C" rx_solve rx_global; +extern "C" rx_solving_options op_global; +extern "C" t_F AMT; +extern "C" t_LAG LAG; +extern "C" t_RATE RATE; +extern "C" t_DUR DUR; +extern "C" t_calc_mtime calc_mtime; -#include "../inst/include/rxode2parse.h" -extern "C" void _rxode2parse_unprotect(); - -extern "C" { - rx_solving_options _rxode2parse_op_global; - rx_solve _rxode2parse_rx_global; - t_F AMT = NULL; - t_LAG LAG = NULL; - t_RATE RATE = NULL; - t_DUR DUR = NULL; - t_calc_mtime calc_mtime = NULL; - - t_ME ME = NULL; - t_IndF IndF = NULL; - - t_getTime _rxode2parse_getTime; - t_locateTimeIndex _rxode2parse_locateTimeIndex; -} +extern "C" t_ME ME; +extern "C" t_IndF IndF; +extern "C" int _locateTimeIndex(double obs_time, rx_solving_options_ind *ind); extern "C" void RSprintf(const char *format, ...); @@ -84,42 +67,40 @@ extern "C" SEXP _rxode2parse_linCmtB() { #include #include -#define op_global _rxode2parse_op_global -#define rx_global _rxode2parse_rx_global -#define AMT _rxode2parse_AMT -#define LAG _rxode2parse_LAG -#define RATE _rxode2parse_RATE -#define DUR _rxode2parse_DUR -#define calc_mtime _rxode2parse_calc_mtime -#define getTime_ _rxode2parse_getTime_ -#define getTime _rxode2parse_getTime -#define _locateTimeIndex _rxode2parse_locateTimeIndex - #include "../inst/include/rxode2parse.h" +extern "C" rx_solve rx_global; +extern "C" rx_solving_options op_global; +extern "C" t_F AMT; +extern "C" t_LAG LAG; +extern "C" t_RATE RATE; +extern "C" t_DUR DUR; +extern "C" t_calc_mtime calc_mtime; + +extern "C" t_ME ME; +extern "C" t_IndF IndF; +extern "C" int _locateTimeIndex(double obs_time, rx_solving_options_ind *ind); + +extern "C" void RSprintf(const char *format, ...); + + extern "C" SEXP _rxode2parse_linCmtB() { SEXP ret = PROTECT(Rf_allocVector(INTSXP, 1)); INTEGER(ret)[0] = 1; UNPROTECT(1); return ret; } -extern "C" void _rxode2parse_unprotect(); - -extern "C" { - rx_solving_options _rxode2parse_op_global; - rx_solve _rxode2parse_rx_global; - t_F AMT = NULL; - t_LAG LAG = NULL; - t_RATE RATE = NULL; - t_DUR DUR = NULL; - t_calc_mtime calc_mtime = NULL; - - t_ME ME = NULL; - t_IndF IndF = NULL; - - t_locateTimeIndex _rxode2parse_locateTimeIndex; - t_getDur _rxode2parse_getDur; -} + +extern "C" rx_solve rx_global; +extern "C" rx_solving_options op_global; +extern "C" t_F AMT; +extern "C" t_LAG LAG; +extern "C" t_RATE RATE; +extern "C" t_DUR DUR; +extern "C" t_calc_mtime calc_mtime; + +extern "C" t_ME ME; +extern "C" t_IndF IndF; extern "C" void RSprintf(const char *format, ...); #include "../inst/include/rxode2parseHandleEvid.h" @@ -2974,7 +2955,6 @@ extern "C" double linCmtB(rx_solve *rx, unsigned int id, dd_rate, dd_dur, dd_ka, dd_tlag2, dd_F2, dd_rate2, dd_dur2); default: - _rxode2parse_unprotect(); Rf_errorcall(R_NilValue, "unsupported sensitivity"); } } diff --git a/src/par_solve.cpp b/src/par_solve.cpp index 9b54aa6c6..c530fc7b6 100644 --- a/src/par_solve.cpp +++ b/src/par_solve.cpp @@ -11,8 +11,8 @@ #include "strncmp.h" #include "timsort.h" #include "../inst/include/rxode2.h" -#include -#include +#include "../inst/include/rxode2parseHandleEvid.h" +#include "../inst/include/rxode2parseGetTime.h" #define SORT gfx::timsort #define isSameTimeOp(xout, xp) (op->stiff == 0 ? isSameTimeDop(xout, xp) : isSameTime(xout, xp)) // dop853 is same time diff --git a/src/parseFuns.h b/src/parseFuns.h index 4c2c84819..b019a9e2d 100644 --- a/src/parseFuns.h +++ b/src/parseFuns.h @@ -7,7 +7,7 @@ #define notThreadSafe 0 -SEXP rxode2parse_getUdf2(const char *fun, const int nargs); +SEXP rxode2_getUdf2(const char *fun, const int nargs); static inline int isAtFunctionArg(const char *name) { return !strcmp("(", name) || @@ -314,7 +314,7 @@ static inline int handleBadFunctions(transFunctions *tf) { } if (foundFun == 0){ int ii = d_get_number_of_children(d_get_child(tf->pn,3))+1; - SEXP lst = PROTECT(rxode2parse_getUdf2(tf->v, ii)); + SEXP lst = PROTECT(rxode2_getUdf2(tf->v, ii)); int udf = INTEGER(VECTOR_ELT(lst, 0))[0]; const char *udfInfo = R_CHAR(STRING_ELT(VECTOR_ELT(lst, 1), 0)); UNPROTECT(1); diff --git a/src/parseLinCmt.c b/src/parseLinCmt.c new file mode 100644 index 000000000..44bc2aba7 --- /dev/null +++ b/src/parseLinCmt.c @@ -0,0 +1,307 @@ +#define USE_FC_LEN_T +#define STRICT_R_HEADERS +#include "parseLinCmt.h" + +char errLin[errLinLen]; +int errOff = 0; + +int _linCmtParsePro=0; + + + +static inline void linCmtParseFinalizeStrings(linCmtStruct *lin, int verbose, + const char *first, const char *end1, const char *end2) { + for (int i = Rf_length(lin->vars); i--;){ + linCmtStr(lin, CHAR(STRING_ELT(lin->vars, i)), &i); + } + linCmtAdjustPars(lin); + lin->trans =-1; + lin->ncmt = -1; + sIni(&(lin->ret0)); + sIni(&(lin->ret)); + if (lin->cl != -1) { + linCmtParseTransCl(lin, verbose); + } else if (lin->kel != -1) { + linCmtParseTranKel(lin, verbose); + } else if (lin->aob != -1) { + linCmtParseAOB(lin, verbose); + } else if (lin->k21 != -1) { + linCmtParseTransK21(lin, verbose); + } else if (lin->alpha != -1) { + linCmtParseTransAlpha(lin, verbose); + } + sAppend(&(lin->ret), "%s", first); + sAppend(&(lin->ret), "%d, %s", lin->ncmt, lin->ret0.s); + sAppend(&(lin->ret), "%s", end1); + if (lin->ka == -1) { + sAppendN(&(lin->ret), "0.0", 3); + if (verbose) RSprintf("\n"); + } else { + sAppend(&(lin->ret), "%s", CHAR(STRING_ELT(lin->vars, lin->ka))); + if (verbose) RSprintf(_(" with first order absorption\n")); + } + sAppend(&(lin->ret), "%s", end2); +} + +static inline SEXP linCmtParseSEXP(linCmtStruct *lin) { + int pro = 0; + SEXP strV = PROTECT(Rf_allocVector(STRSXP, 1)); pro++; + SEXP lst = PROTECT(Rf_allocVector(VECSXP, 3)); pro++; + SEXP lstN = PROTECT(Rf_allocVector(STRSXP, 3)); pro++; + + SEXP transSXP = PROTECT(Rf_allocVector(INTSXP, 1)); pro++; + INTEGER(transSXP)[0] = lin->trans; + + SEXP ncmtSXP = PROTECT(Rf_allocVector(INTSXP, 1)); pro++; + INTEGER(ncmtSXP)[0] = lin->ncmt; + + SET_STRING_ELT(strV, 0, mkChar(lin->ret.s)); + SET_VECTOR_ELT(lst, 0, strV); + SET_STRING_ELT(lstN, 0, mkChar("str")); + + SET_STRING_ELT(lstN, 1, mkChar("ncmt")); + SET_VECTOR_ELT(lst, 1, ncmtSXP); + + SET_STRING_ELT(lstN, 2, mkChar("trans")); + SET_VECTOR_ELT(lst, 2, transSXP); + + setAttrib(lst, R_NamesSymbol, lstN); + sFree(&(lin->ret0)); + sFree(&(lin->ret)); + UNPROTECT(pro); + if (lin->trans == -1) { + UNPROTECT(_linCmtParsePro); + _linCmtParsePro=0; + _rxode2parse_unprotect(); + err_trans("could not figure out linCmt() model"); + } + _linCmtParsePro=0; + return lst; +} + + +SEXP _linCmtParse(SEXP vars0, SEXP inStr, SEXP verboseSXP) { + linCmtStruct lin; + linCmtIni(&lin); + lin.vars = vars0; + int verbose = 0; + if (TYPEOF(verboseSXP) == LGLSXP) { + verbose = INTEGER(verboseSXP)[0]; + } + const char *first = "linCmtB(rx__PTR__, t, "; + const char *mid0 = "0, "; + const char *end1 = "rx_tlag, rx_F, rx_rate, rx_dur,"; + const char *end2 = ", yrx_tlag2, rx_F2, rx_rate2, rx_dur2)"; + int type = TYPEOF(inStr); + if (type == STRSXP) { + int len = Rf_length(inStr); + if (len > 0) { + first = CHAR(STRING_ELT(inStr, 0)); + } + if (len > 1) { + mid0 = CHAR(STRING_ELT(inStr, 1)); + } + if (len > 2) { + end1 = CHAR(STRING_ELT(inStr, 2)); + } + if (len > 3) { + end2 = CHAR(STRING_ELT(inStr, 3)); + } + } + lin.mid = mid0; + linCmtParseFinalizeStrings(&lin, verbose, first, end1, end2); + return linCmtParseSEXP(&lin); +} + +static inline void linCmtGenKa(linCmtGenStruct *linG) { + // depot, central + int i; + for (i = 0; i < depotLines.n; i++){ + switch(depotLines.lType[i]){ + case FBIO: + sClear(&(linG->d_F)); + sAppend(&(linG->d_F), "%s, ", depotLines.line[i]); + break; + case ALAG: + sClear(&(linG->d_tlag)); + sAppend(&(linG->d_tlag), "%s, ", depotLines.line[i]); + break; + case RATE: + sClear(&(linG->d_rate1)); + sAppend(&(linG->d_rate1), "%s, ", depotLines.line[i]); + break; + case DUR: + sClear(&(linG->d_dur1)); + sAppend(&(linG->d_dur1), "%s, ", depotLines.line[i]); + break; + default: + RSprintf("unknown depot line(%d): %s \n", depotLines.lType[i], depotLines.line[i]); + } + } + for (i = 0; i < centralLines.n; i++){ + switch(centralLines.lType[i]){ + case FBIO: + sClear(&(linG->d_F2)); + sAppend(&(linG->d_F2), "%s, ", centralLines.line[i]); + break; + case ALAG: + sClear(&(linG->d_tlag2)); + sAppend(&(linG->d_tlag2), ", %s, ", centralLines.line[i]); + break; + case RATE: + sClear(&(linG->d_rate2)); + sAppend(&(linG->d_rate2), "%s, ", centralLines.line[i]); + break; + case DUR: + sClear(&(linG->d_dur2)); + sAppend(&(linG->d_dur2), "%s)", centralLines.line[i]); + break; + } + } +} + +static inline void linCmtGenBolus(linCmtGenStruct *linG) { + int i; + for (i = 0; i < depotLines.n; i++){ + switch(depotLines.lType[i]){ + case FBIO: + sAppendN(&(linG->last), "'f(depot)' ", 11); + break; + case ALAG: + sAppendN(&(linG->last), "'alag(depot)' ", 14); + break; + case RATE: + sAppend(&(linG->last), "'rate(depot)' ", 14); + break; + case DUR: + sAppend(&(linG->last), "'dur(depot)' ", 13); + break; + default: + RSprintf("unknown depot line(%d): %s \n", depotLines.lType[i], depotLines.line[i]); + } + } + if (linG->last.o) { + errLin[0] = '\0'; + errOff=0; + snprintf(errLin, errLinLen, "%s does not exist without a 'depot' compartment, specify a 'ka' parameter", linG->last.s); + errOff=strlen(errLin); + _rxode2parse_unprotect(); + err_trans(errLin); + } + // central only + for (i = 0; i < centralLines.n; i++){ + switch(centralLines.lType[i]){ + case FBIO: + sClear(&(linG->d_F)); + sAppend(&(linG->d_F), "%s, ", centralLines.line[i]); + break; + case ALAG: + sClear(&(linG->d_tlag)); + sAppend(&(linG->d_tlag), "%s, ", centralLines.line[i]); + break; + case RATE: + sClear(&(linG->d_rate1)); + sAppend(&(linG->d_rate1), "%s, ", centralLines.line[i]); + break; + case DUR: + sClear(&(linG->d_dur1)); + sAppend(&(linG->d_dur1), "%s, ", centralLines.line[i]); + break; + } + } +} + +static inline int linCmtGenFinalize(linCmtGenStruct *linG, SEXP linCmt, SEXP vars, SEXP linCmtSens, SEXP verbose, SEXP linCmtP) { + for (int i = 0; i < sbNrmL.n; i++){ + if (sbNrmL.lProp[i]== -100){ + char *line = sbNrmL.line[i]; + if (line[0] != '\0') { + while (strncmp(line, "linCmt(", 7)){ + if (line[0] == '\0') { + return 1; + } + else sPut(&(linG->last2), line[0]); + line++; + } + } + if (strlen(line) > 7) line +=7; + else { + return 1; + } + sAppend(&(linG->last2), "%s", CHAR(STRING_ELT(VECTOR_ELT(linCmtP, 0), 0))); + while (line[0] != ')'){ + if (line[0] == '\0') { + return 1; + } + if (line[0] == '('){ + return 2; + } + line++; + } + if (line[0] != '\0') sAppend(&(linG->last2), "%s", ++line); + } else { + sAppend(&(linG->last2), "%s", sbNrmL.line[i]); + } + } + return 0; +} + +static inline SEXP linCmtGenSEXP(linCmtGenStruct *linG, SEXP linCmt, SEXP vars, SEXP linCmtSens, SEXP verbose) { + int pro=0; + SEXP inStr = PROTECT(Rf_allocVector(STRSXP, 4)); pro++; + int doSens = 0; + if (TYPEOF(linCmtSens) == INTSXP){ + doSens = INTEGER(linCmtSens)[0]; + } + sAppend(&(linG->last), "%s%s%s%s", linG->d_tlag.s, linG->d_F.s, linG->d_rate1.s, linG->d_dur1.s); + SET_STRING_ELT(inStr, 2, mkChar(linG->last.s)); + sClear(&(linG->last)); + sAppend(&(linG->last), "%s%s%s%s",linG->d_tlag2.s, linG->d_F2.s, linG->d_rate2.s, linG->d_dur2.s); + SET_STRING_ELT(inStr, 3, mkChar(linG->last.s)); + sClear(&(linG->last)); + if (doSens == 2){ + sAppend(&(linG->last), "linCmtB(rx__PTR__, t, %d, ", INTEGER(linCmt)[0]); + SET_STRING_ELT(inStr, 0, mkChar(linG->last.s)); + SET_STRING_ELT(inStr, 1, mkChar("0, ")); + } else { + if (doSens == 1){ + sAppend(&(linG->last), "linCmtA(rx__PTR__, t, %d, ", INTEGER(linCmt)[0]); + } else if (doSens == 3) { + sAppend(&(linG->last), "linCmtC(rx__PTR__, t, %d, ", INTEGER(linCmt)[0]); + } + SET_STRING_ELT(inStr, 0, mkChar(linG->last.s)); + SET_STRING_ELT(inStr, 1, mkChar("")); + } + _linCmtParsePro=pro; + SEXP linCmtP = PROTECT(_linCmtParse(vars, inStr, verbose)); pro++; + switch(linCmtGenFinalize(linG, linCmt, vars, linCmtSens, verbose, linCmtP)) { + case 1: + UNPROTECT(pro); + _rxode2parse_unprotect(); + err_trans("linCmt() bad parse"); + return R_NilValue; + case 2: + UNPROTECT(pro); + _rxode2parse_unprotect(); + err_trans("linCmt() cannot have any extra parentheses in it"); + return R_NilValue; + break; + } + SEXP ret = PROTECT(Rf_allocVector(STRSXP,1)); pro++; + SET_STRING_ELT(ret, 0, mkChar(linG->last2.s)); + UNPROTECT(pro); + return ret; +} + +linCmtGenStruct _linCmtGenStruct; + +SEXP _rxode2_linCmtGen(SEXP linCmt, SEXP vars, SEXP linCmtSens, SEXP verbose) { + linCmtGenIni(&_linCmtGenStruct); + /* SEXP ret = PROTECT(Rf_allocVector(STRSXP, 1)); */ + if (tb.hasKa){ + linCmtGenKa(&_linCmtGenStruct); + } else { + linCmtGenBolus(&_linCmtGenStruct); + } + return linCmtGenSEXP(&_linCmtGenStruct, linCmt, vars, linCmtSens, verbose); +} diff --git a/src/rxData.cpp b/src/rxData.cpp index 033b95ce5..d8fbefabe 100644 --- a/src/rxData.cpp +++ b/src/rxData.cpp @@ -29,7 +29,7 @@ #include "checkmate.h" #include // for uint64_t rather than unsigned long long #include "../inst/include/rxode2.h" -#include +#include "../inst/include/rxode2parseVer.h" #include "../inst/include/rxode2random_fillVec.h" #include "rxomp.h" #ifdef ENABLE_NLS @@ -50,7 +50,7 @@ typedef void (*seedEng_t)(int ncores); extern seedEng_t seedEng; #include "cbindThetaOmega.h" -#include +#include "../inst/include/rxode2parseHandleEvid.h" #include "rxThreadData.h" //#include "seed.h" @@ -67,17 +67,13 @@ extern "C" int getThrottle(); extern "C" int getRxThreads(const int64_t n, const bool throttle); extern "C" void rxode2_assign_fn_pointers_(const char *mv); extern "C" void setSilentErr(int silent); -extern "C" SEXP _rxode2parse_assignUdf(SEXP in); -extern "C" SEXP _rxode2parse_udfEnvSet(SEXP udf); -extern "C" SEXP _rxode2parse_udfReset(); -extern "C" SEXP _rxode2parse_rxC(SEXP in); - -extern "C" { - typedef SEXP (*_rxode2parse_getForder_type)(void); - extern _rxode2parse_getForder_type getForder; - typedef int (*_rxode2parse_useForder_type)(void); - extern _rxode2parse_useForder_type useForder; -} +extern "C" SEXP _rxode2_assignUdf(SEXP in); +extern "C" SEXP _rxode2_udfEnvSet(SEXP udf); +extern "C" SEXP _rxode2_udfReset(); +extern "C" SEXP _rxode2_rxC(SEXP in); + +Function getForder(); +extern "C" int useForder(void); #include "../inst/include/rxode2_as.h" @@ -808,7 +804,7 @@ List rxModelVars_character(const RObject &obj){ return f(obj); } -List rxModelVars_list(const RObject &obj){ +List rxModelVars_list(const RObject &obj) { bool params=false, lhs=false, state=false, trans=false, ini=false, model=false, md5=false, dfdy=false; List lobj = asList(obj, "rxModelVars_list"); CharacterVector nobj = lobj.names(); @@ -2448,7 +2444,7 @@ void resetFkeep(); //' @export // [[Rcpp::export]] LogicalVector rxSolveFree(){ - _rxode2parse_udfReset(); + _rxode2_udfReset(); resetFkeep(); if (!_globals.alloc) return true; rx_solve* rx = getRxSolve_(); @@ -4745,8 +4741,8 @@ SEXP rxSolve_(const RObject &obj, const List &rxControl, } } - _rxode2parse_udfEnvSet(rxSolveDat->mv[RxMv_udf]); - LogicalVector recompileUdf = _rxode2parse_assignUdf(rxSolveDat->mv[RxMv_udf]); + _rxode2_udfEnvSet(rxSolveDat->mv[RxMv_udf]); + LogicalVector recompileUdf = _rxode2_assignUdf(rxSolveDat->mv[RxMv_udf]); if (recompileUdf[0]) { Function rxode2 = getRxFn("rxode2"); @@ -6236,7 +6232,7 @@ CharacterVector rxC(RObject obj){ } else if (rxIs(obj, "rxDll")){ rets = as(as(obj)["c"]); } else if (rxIs(obj, "character")) { - Nullable rxCp = _rxode2parse_rxC(obj); + Nullable rxCp = _rxode2_rxC(obj); if (!rxCp.isNull()) { return as(rxCp); } diff --git a/src/rxStack.cpp b/src/rxStack.cpp index a52305aef..468a7dd7c 100644 --- a/src/rxStack.cpp +++ b/src/rxStack.cpp @@ -2,13 +2,14 @@ //#undef NDEBUG #define STRICT_R_HEADERS #include -#include +#include "../inst/include/rxode2parse.h" using namespace Rcpp; #define rxModelVars(a) rxModelVars_(a) -extern "C" SEXP rxModelVars_(SEXP); + +List rxModelVars(const RObject &obj); bool hasElement(CharacterVector one, std::string what){ for (unsigned int i = one.size(); i--;){ diff --git a/src/rxode2_df.cpp b/src/rxode2_df.cpp index a3724f791..27f810b0e 100644 --- a/src/rxode2_df.cpp +++ b/src/rxode2_df.cpp @@ -31,9 +31,9 @@ #include "checkmate.h" #include // for uint64_t rather than unsigned long long #include "../inst/include/rxode2.h" -#include -#include -#include +#include "../inst/include/rxode2parseVer.h" +#include "../inst/include/rxode2parseHandleEvid.h" +#include "../inst/include/rxode2parseGetTime.h" #include "par_solve.h" #include #include "strncmp.h" diff --git a/src/rxode2parse.cpp b/src/rxode2parse.cpp deleted file mode 100644 index 940d97ddd..000000000 --- a/src/rxode2parse.cpp +++ /dev/null @@ -1,217 +0,0 @@ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#define USE_FC_LEN_T -#define STRICT_R_HEADERS -#include -#include "../inst/include/rxode2.h" -#include -#ifdef ENABLE_NLS -#include -#define _(String) dgettext ("rxode2", String) -/* replace pkg as appropriate */ -#else -#define _(String) (String) -#endif - -using namespace Rcpp; -using namespace arma; - -extern Function loadNamespace; -bool rxode2parse_loaded = false; -Environment rxode2parse; - -extern "C" { - typedef SEXP (*_rxode2_convertId_type)(SEXP); - - _rxode2_convertId_type _rxode2parse__convertId_; - - typedef SEXP (*_rxode2_etTransParse_type)(SEXP, SEXP, SEXP, SEXP, SEXP, - SEXP, SEXP, SEXP, SEXP, SEXP, - SEXP); - _rxode2_etTransParse_type _rxode2_etTransParseP; - - typedef SEXP (*_rxode2_chin_type)(SEXP, SEXP); - - _rxode2_chin_type _rxode2_chin; - typedef SEXP (*_rxode2parse_getForder_type)(void); - _rxode2parse_getForder_type getForder; - typedef int (*_rxode2parse_useForder_type)(void); - _rxode2parse_useForder_type useForder; - -} - -extern "C" SEXP assignRxode2ParsePtrs(void) { - BEGIN_RCPP - if (!rxode2parse_loaded) { - rxode2parse_loaded = true; - rxode2parse = loadNamespace("rxode2parse"); - Function funPtrs = rxode2parse[".rxode2parseFunPtrs"]; - List ptr = as(funPtrs()); - _rxode2parse__convertId_ = (_rxode2_convertId_type)(R_ExternalPtrAddr(ptr[0])); - _rxode2_etTransParseP=(_rxode2_etTransParse_type) (R_ExternalPtrAddr(ptr[2])); - _rxode2_chin=(_rxode2_chin_type) (R_ExternalPtrAddr(ptr[3])); - getForder=(_rxode2parse_getForder_type) (R_ExternalPtrAddr(ptr[4])); - useForder=(_rxode2parse_useForder_type) (R_ExternalPtrAddr(ptr[5])); - } - END_RCPP -} - -extern "C" SEXP _rxode2_convertId_(SEXP id) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - return _rxode2parse__convertId_(id); - END_RCPP -} - -extern "C" SEXP chin(SEXP a, SEXP b) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - return _rxode2_chin(a, b); - END_RCPP -} - -extern "C" SEXP _rxode2_codeLoaded(void) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".codeLoaded"]); - return fun(); - END_RCPP -} - -extern "C" SEXP _rxode2parse_rxC(SEXP in) { -BEGIN_RCPP - if (TYPEOF(in) != STRSXP) return R_NilValue; - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".rxC"]); - return wrap(fun(in)); -END_RCPP -} - -extern "C" SEXP _rxode2parse_assignUdf(SEXP in) { -BEGIN_RCPP - if (Rf_length(in) == 0 || Rf_length(in) == 1) { - return wrap(LogicalVector::create(false)); - } - if (TYPEOF(in) != INTSXP) { - return wrap(LogicalVector::create(false)); - } - if (Rf_isNull(Rf_getAttrib(in, R_NamesSymbol))) { - return wrap(LogicalVector::create(false)); - } - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".setupUdf"]); - LogicalVector needRecompile = fun(in); - return wrap(needRecompile); -END_RCPP -} - -extern "C" SEXP _rxode2parse_udfEnvSet(SEXP udf) { -BEGIN_RCPP - if (Rf_isNull(udf)) { - return R_NilValue; - } - if (Rf_length(udf) == 0 || Rf_length(udf) == 1) { - return R_NilValue; - } - if (TYPEOF(udf) != INTSXP) { - return R_NilValue; - } - if (Rf_isNull(Rf_getAttrib(udf, R_NamesSymbol))) { - return R_NilValue; - } - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".udfEnvSetUdf"]); - fun(udf); - return R_NilValue; - END_RCPP -} - -extern "C" SEXP _rxode2parse_udfReset() { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun2 = as(rxode2parse[".udfEnvReset"]); - fun2(); - return R_NilValue; - END_RCPP -} - -extern "C" SEXP _rxode2_codegen(SEXP c_file, SEXP prefix, SEXP libname, SEXP pMd5, SEXP timeId, SEXP lastMv, SEXP goodFuns) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".codegen"]); - return fun(c_file, prefix, libname, pMd5, timeId, lastMv, goodFuns); - END_RCPP -} - -extern "C" SEXP _rxode2_parseModel(SEXP type) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".parseModel"]); - return fun(type); - END_RCPP -} - -extern "C" SEXP _rxode2_isLinCmt(void) { - BEGIN_RCPP - if (!rxode2parse_loaded) { - rxode2parse_loaded = true; - rxode2parse = loadNamespace("rxode2parse"); - } - Function fun = as(rxode2parse[".isLinCmt"]); - return fun(); - END_RCPP -} - -extern "C" SEXP _rxode2_trans(SEXP parse_file, SEXP prefix, SEXP model_md5, SEXP parseStr, - SEXP isEscIn, SEXP inME, SEXP goodFuns, SEXP fullPrintIn) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".trans"]); - return fun(parse_file, prefix, model_md5, parseStr, isEscIn, inME, goodFuns, fullPrintIn); - END_RCPP -} - -extern "C" SEXP _linCmtParse(SEXP vars, SEXP inStr, SEXP verbose) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".linCmtParse"]); - return fun(vars, inStr, verbose); - END_RCPP -} - -extern "C" SEXP _rxode2_linCmtGen(SEXP linCmt, SEXP vars, SEXP linCmtSens, SEXP verbose) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".linCmtGen"]); - return fun(linCmt, vars, linCmtSens, verbose); - END_RCPP -} - -extern "C" SEXP parseFreeSexp(SEXP last) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".parseFreeSexp"]); - return fun(last); - END_RCPP -} - - -extern "C" void parseFree(int last) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - SEXP iv = PROTECT(Rf_allocVector(INTSXP, 1)); - INTEGER(iv)[0] = last; - parseFreeSexp(iv); - UNPROTECT(1); - VOID_END_RCPP -} - - -extern "C" SEXP _calcDerived(SEXP ncmtSXP, SEXP transSXP, SEXP inp, SEXP sigdigSXP) { - BEGIN_RCPP - assignRxode2ParsePtrs(); - Function fun = as(rxode2parse[".calcDerived"]); - return fun(ncmtSXP, transSXP, inp, sigdigSXP); - END_RCPP -} diff --git a/src/rxthreefry.cpp b/src/rxthreefry.cpp index 143fd4ddd..26d0de499 100644 --- a/src/rxthreefry.cpp +++ b/src/rxthreefry.cpp @@ -4,7 +4,7 @@ #define min2( a , b ) ( (a) < (b) ? (a) : (b) ) #include #include "../inst/include/rxode2.h" -#include +#include "../inst/include/rxode2parse.h" #include #include #include "checkmate.h" diff --git a/src/seed.cpp b/src/seed.cpp index 621c7b95d..98c16e846 100644 --- a/src/seed.cpp +++ b/src/seed.cpp @@ -4,7 +4,7 @@ #define min2( a , b ) ( (a) < (b) ? (a) : (b) ) #include #include "../inst/include/rxode2.h" -#include +#include "../inst/include/rxode2parse.h" #include #ifdef ENABLE_NLS #include diff --git a/src/tran.c b/src/tran.c index 8c8c7fb5a..4a08fe9ce 100644 --- a/src/tran.c +++ b/src/tran.c @@ -6,6 +6,7 @@ #include #include /* dj: import intptr_t */ //#include "ode.h" +#include "../inst/include/rxode2.h" #include "../inst/include/rxode2parseSbuf.h" #include "getOption.h" #include "parseLinCmt.h" @@ -605,7 +606,7 @@ static inline void finalizeSyntaxError(void) { void _rxode2parse_assignTranslation(SEXP df); SEXP getRxode2ParseDf(void); -SEXP _rxode2parse_trans(SEXP parse_file, SEXP prefix, SEXP model_md5, SEXP parseStr, +SEXP _rxode2_trans(SEXP parse_file, SEXP prefix, SEXP model_md5, SEXP parseStr, SEXP isEscIn, SEXP inME, SEXP goodFuns, SEXP fullPrintIn){ const char *in = NULL; _rxode2parse_assignTranslation(getRxode2ParseDf()); @@ -619,7 +620,7 @@ SEXP _rxode2parse_trans(SEXP parse_file, SEXP prefix, SEXP model_md5, SEXP parse return lst; } -SEXP _rxode2parse_parseModel(SEXP type){ +SEXP _rxode2_parseModel(SEXP type){ if (!sbPm.o){ _rxode2parse_unprotect(); err_trans("model no longer loaded in memory"); @@ -628,14 +629,14 @@ SEXP _rxode2parse_parseModel(SEXP type){ SEXP pm; switch (iT){ case 1: - pm = PROTECT(allocVector(STRSXP, sbPmDt.n)); + pm = PROTECT(Rf_allocVector(STRSXP, sbPmDt.n)); for (int i = 0; i < sbPmDt.n; i++){ SET_STRING_ELT(pm, i, mkChar(sbPmDt.line[i])); } break; default: - pm = PROTECT(allocVector(STRSXP, sbPm.n)); + pm = PROTECT(Rf_allocVector(STRSXP, sbPm.n)); for (int i = 0; i < sbPm.n; i++){ SET_STRING_ELT(pm, i, mkChar(sbPm.line[i])); } @@ -645,8 +646,8 @@ SEXP _rxode2parse_parseModel(SEXP type){ return pm; } -SEXP _rxode2parse_codeLoaded(void){ - SEXP pm = PROTECT(allocVector(INTSXP, 1)); +SEXP _rxode2_codeLoaded(void){ + SEXP pm = PROTECT(Rf_allocVector(INTSXP, 1)); if (!sbPm.o || !sbNrm.o){ INTEGER(pm)[0]=0; } else { @@ -656,8 +657,8 @@ SEXP _rxode2parse_codeLoaded(void){ return pm; } -SEXP _rxode2parse_isLinCmt(void) { - SEXP ret = PROTECT(allocVector(INTSXP, 1)); +SEXP _rxode2_isLinCmt(void) { + SEXP ret = PROTECT(Rf_allocVector(INTSXP, 1)); INTEGER(ret)[0]=tb.linCmt; UNPROTECT(1); return ret; diff --git a/src/udf.cpp b/src/udf.cpp index a3e89fdeb..56c0b471d 100644 --- a/src/udf.cpp +++ b/src/udf.cpp @@ -3,21 +3,64 @@ #include using namespace Rcpp; -Function loadNamespace("loadNamespace", R_BaseNamespace); -//Function requireNamespace("requireNamespace", R_BaseNamespace); +Function getRxFn(std::string name); -extern "C" SEXP rxode2parse_getUdf2(const char *fun, const int nargs) { +extern "C" SEXP _rxode2_assignUdf(SEXP in) { + BEGIN_RCPP + if (Rf_length(in) == 0 || Rf_length(in) == 1) { + return wrap(LogicalVector::create(false)); + } + if (TYPEOF(in) != INTSXP) { + return wrap(LogicalVector::create(false)); + } + if (Rf_isNull(Rf_getAttrib(in, R_NamesSymbol))) { + return wrap(LogicalVector::create(false)); + } + Function fun = as(getRxFn(".setupUdf")); + LogicalVector needRecompile = fun(in); + return wrap(needRecompile); + END_RCPP +} + +extern "C" SEXP _rxode2_udfEnvSet(SEXP udf) { + BEGIN_RCPP + if (Rf_isNull(udf)) { + return R_NilValue; + } + if (Rf_length(udf) == 0 || Rf_length(udf) == 1) { + return R_NilValue; + } + if (TYPEOF(udf) != INTSXP) { + return R_NilValue; + } + if (Rf_isNull(Rf_getAttrib(udf, R_NamesSymbol))) { + return R_NilValue; + } + Function fun = as(getRxFn(".udfEnvSetUdf")); + fun(udf); + return R_NilValue; + END_RCPP + } + +extern "C" SEXP _rxode2_udfReset() { + BEGIN_RCPP + Function fun2 = as(getRxFn(".udfEnvReset")); + fun2(); + return R_NilValue; + END_RCPP + } + + +extern "C" SEXP rxode2_getUdf2(const char *fun, const int nargs) { BEGIN_RCPP - Environment rxode2parseNS = loadNamespace("rxode2parse"); - Function rxode2parse_getUdf_ = as(rxode2parseNS[".getUdfInfo"]); - return rxode2parse_getUdf_(fun, nargs); + Function rxode2_getUdf_ = as(getRxFn(".getUdfInfo")); + return rxode2_getUdf_(fun, nargs); END_RCPP } -extern "C" SEXP _rxode2parse_evalUdfS(const char *fun, int n, const double *args) { +extern "C" SEXP _rxode2_evalUdfS(const char *fun, int n, const double *args) { BEGIN_RCPP - Environment rxode2parseNS = loadNamespace("rxode2parse"); - Function rxode2parse_evalUdf = as(rxode2parseNS[".udfCall"]); + Function rxode2_evalUdf = as(getRxFn(".udfCall")); List retL(n); CharacterVector funC(1); funC = fun; @@ -26,24 +69,23 @@ BEGIN_RCPP nv[0] = args[i]; retL[i] = nv; } - NumericVector ret0 = rxode2parse_evalUdf(funC, retL); + NumericVector ret0 = rxode2_evalUdf(funC, retL); NumericVector ret(1); ret[0] = ret0[0]; return wrap(ret); END_RCPP } -extern "C" double _rxode2parse_evalUdf(const char *fun, int n, const double *args) { - SEXP ret = PROTECT(_rxode2parse_evalUdfS(fun, n, args)); +extern "C" double _rxode2_evalUdf(const char *fun, int n, const double *args) { + SEXP ret = PROTECT(_rxode2_evalUdfS(fun, n, args)); double r = REAL(ret)[0]; UNPROTECT(1); return r; } -extern "C" SEXP _rxode2parse_resetUdf() { +extern "C" SEXP _rxode2_resetUdf() { BEGIN_RCPP - Environment rxode2parseNS = loadNamespace("rxode2parse"); - Function resetUdf = as(rxode2parseNS[".udfReset"]); + Function resetUdf = as(getRxFn(".udfReset")); resetUdf(); return R_NilValue; END_RCPP @@ -51,8 +93,7 @@ END_RCPP extern "C" SEXP _rxode2parse_getUdf() { BEGIN_RCPP - Environment rxode2parseNS = loadNamespace("rxode2parse"); - Function getUdf = as(rxode2parseNS[".udfInfo"]); + Function getUdf = as(getRxFn(".udfInfo")); return getUdf(); END_RCPP } diff --git a/src/utilc.c b/src/utilc.c index c713f7e67..8f9fb036d 100644 --- a/src/utilc.c +++ b/src/utilc.c @@ -820,22 +820,22 @@ SEXP _vecDF(SEXP cv, SEXP n_) { if (n <= 0) Rf_errorcall(R_NilValue, _("'n' must be greater than 0")); int pro = 0; int len = length(cv); - SEXP ret = PROTECT(allocVector(VECSXP, len)); pro++; - SEXP retN = PROTECT(allocVector(STRSXP, len)); pro++; + SEXP ret = PROTECT(Rf_allocVector(VECSXP, len)); pro++; + SEXP retN = PROTECT(Rf_allocVector(STRSXP, len)); pro++; SEXP cvN = getAttrib(cv, R_NamesSymbol); for (int i = len; i--;) { - SEXP tmp = PROTECT(allocVector(REALSXP, n)); pro++; + SEXP tmp = PROTECT(Rf_allocVector(REALSXP, n)); pro++; for (int j = n; j--;) { REAL(tmp)[j] = REAL(cv)[i]; } SET_VECTOR_ELT(ret, i, tmp); SET_STRING_ELT(retN, i, STRING_ELT(cvN, i)); } - SEXP sexp_rownames = PROTECT(allocVector(INTSXP,2)); pro++; + SEXP sexp_rownames = PROTECT(Rf_allocVector(INTSXP,2)); pro++; INTEGER(sexp_rownames)[0] = NA_INTEGER; INTEGER(sexp_rownames)[1] = -n; setAttrib(ret, R_RowNamesSymbol, sexp_rownames); - SEXP sexp_class = PROTECT(allocVector(STRSXP, 1)); pro++; + SEXP sexp_class = PROTECT(Rf_allocVector(STRSXP, 1)); pro++; SET_STRING_ELT(sexp_class,0,Rf_mkChar("data.frame")); setAttrib(ret, R_ClassSymbol, sexp_class); setAttrib(ret, R_NamesSymbol, retN); @@ -878,10 +878,10 @@ SEXP _cbindOme(SEXP et_, SEXP mat_, SEXP n_) { lenItem = n; } int pro = 0; - SEXP ret = PROTECT(allocVector(VECSXP, len1+len2)); pro++; - SEXP retN = PROTECT(allocVector(STRSXP, len1+len2)); pro++; + SEXP ret = PROTECT(Rf_allocVector(VECSXP, len1+len2)); pro++; + SEXP retN = PROTECT(Rf_allocVector(STRSXP, len1+len2)); pro++; for (int i = len1; i--; ) { - SEXP tmp = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP tmp = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; SEXP in = VECTOR_ELT(et_, i); int l = lenOut; for (int j = len1a; j--;) { @@ -893,16 +893,16 @@ SEXP _cbindOme(SEXP et_, SEXP mat_, SEXP n_) { SET_STRING_ELT(retN, i, STRING_ELT(etN, i)); } for (int i = len2; i--; ) { - SEXP tmp = PROTECT(allocVector(REALSXP, lenOut)); pro++; + SEXP tmp = PROTECT(Rf_allocVector(REALSXP, lenOut)); pro++; memcpy(&(REAL(tmp)[0]), &(REAL(mat_)[lenOut*i]), lenOut*sizeof(double)); SET_VECTOR_ELT(ret, i+len1, tmp); SET_STRING_ELT(retN, i+len1, STRING_ELT(matDN, i)); } - SEXP sexp_rownames = PROTECT(allocVector(INTSXP,2)); pro++; + SEXP sexp_rownames = PROTECT(Rf_allocVector(INTSXP,2)); pro++; INTEGER(sexp_rownames)[0] = NA_INTEGER; INTEGER(sexp_rownames)[1] = -lenOut; setAttrib(ret, R_RowNamesSymbol, sexp_rownames); - SEXP sexp_class = PROTECT(allocVector(STRSXP, 1)); pro++; + SEXP sexp_class = PROTECT(Rf_allocVector(STRSXP, 1)); pro++; SET_STRING_ELT(sexp_class,0,Rf_mkChar("data.frame")); setAttrib(ret, R_ClassSymbol, sexp_class); setAttrib(ret, R_NamesSymbol, retN);