diff --git a/R/RcppExports.R b/R/RcppExports.R index 4a18abbb0..d2cf89678 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -116,25 +116,6 @@ etRep_ <- function(curEt, times, wait, ids, handleSamples, waitType, ii) { .Call(`_rxode2_etRep_`, curEt, times, wait, ids, handleSamples, waitType, ii) } -#' Force using base order for rxode2 radix sorting -#' -#' @param forceBase boolean indicating if rxode2 should use R's -#' [order()] for radix sorting instead of -#' `data.table`'s parallel radix sorting. -#' -#' @return NILL; called for side effects -#' -#' @examples -#' \donttest{ -#' forderForceBase(TRUE) # Use base `order` for rxode2 sorts -#' forderForceBase(FALSE) # Use `data.table` for rxode2 sorts -#' } -#' @export -#' @keywords internal -forderForceBase <- function(forceBase = FALSE) { - .Call(`_rxode2_forderForceBase`, forceBase) -} - #' Set Initial conditions to time zero instead of the first observed/dosed time #' #' @param ini0 When `TRUE` (default), set initial conditions to time diff --git a/R/etTran.R b/R/etTran.R index d42c30ff4..3b4387739 100644 --- a/R/etTran.R +++ b/R/etTran.R @@ -23,29 +23,6 @@ .m$idxi } -.DTEnv <- NULL -.getDTEnv <- function() { - if (is.null(.DTEnv)) { - if (requireNamespace("data.table", quietly = TRUE)) { - .env <- loadNamespace("data.table") - if (utils::compareVersion( - as.character( - utils::packageVersion("data.table") - ), - "1.12.4" - ) >= 0) { - assignInMyNamespace(".DTEnv", .env) - return(.env) - } - } - .env <- new.env(parent = emptyenv()) - assignInMyNamespace(".DTEnv", .env) - return(.env) - } else { - return(.DTEnv) - } -} - .convertExtra <- function(dat) { d <- as.data.frame(dat) .colNames0 <- colnames(d) diff --git a/R/forder.R b/R/forder.R new file mode 100644 index 000000000..b3658d4c1 --- /dev/null +++ b/R/forder.R @@ -0,0 +1,69 @@ +.forderEnv <- new.env() +.forderEnv$useBase <- FALSE + + +.forder3 <- function(c1,c2,c3, decreasing=FALSE) { + data.table::data.table(c1=c1, + c2=c2, + c3=c3, + decreasing=decreasing, + na.last=TRUE)[order(c1, c2, c3), which=TRUE] +} + +.border3 <- function(c1,c2,c3, decreasing=FALSE) { + base::order(c1, c2, c3, decreasing=decreasing, na.last=NA, method="radix") +} + +.forder1 <- function(c1, decreasing=FALSE) { + data.table::data.table(c1=c1)[order(c1, decreasing=decreasing, na.last=TRUE), which=TRUE] +} + +.border1 <- function(c1, decreasing=FALSE) { + base::order(c1, na.last=NA, decreasing=decreasing, method="radix") +} + +.order1 <- function(c1, decreasing=FALSE) { + if (.forderEnv$useBase) { + .border1(c1, decreasing=decreasing) + } else { + .forder1(c1, decreasing=decreasing) + } +} + +.order3 <- function(c1,c2,c3, decreasing=FALSE) { + if (.forderEnv$useBase) { + .border3(c1,c2,c3, decreasing=decreasing) + } else { + .forder3(c1,c2,c3, decreasing=decreasing) + } +} +#' Force using base order for rxode2 radix sorting +#' +#' @param forceBase boolean indicating if rxode2 should use R's +#' [order()] for radix sorting instead of +#' `data.table`'s parallel radix sorting. +#' +#' @return value of `forceBase` (can change if `data.table` is not +#' available) +#' +#' @examples +#' \donttest{ +#' forderForceBase(TRUE) # Use base `order` for rxode2 sorts +#' forderForceBase(FALSE) # Use `data.table` for rxode2 sorts +#' } +#' @export +#' @keywords internal +forderForceBase <- function(forceBase = FALSE){ + if (forceBase) { + .forderEnv$useBase <- forceBase + } else if (requireNamespace("data.table", quietly = TRUE)) { + .forderEnv$useBase <- forceBase + } else { + .forderEnv$useBase <- TRUE + } + invisible(.forderEnv$useBase) +} + +.chin <- function(x, table) { + x %in% table +} diff --git a/R/rxode-options.R b/R/rxode-options.R index 5978a8a9d..066014d24 100644 --- a/R/rxode-options.R +++ b/R/rxode-options.R @@ -75,6 +75,7 @@ } .ggplot2Fix() .linkAll() + forderForceBase(FALSE) } ## nocov end .iniLotriPtrs <- function() { @@ -125,6 +126,7 @@ "\n========================================\n" ) } + forderForceBase(FALSE) } .onUnload <- function(libpath) { diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 3e895b48b..0b891ec76 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -251,17 +251,6 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// forderForceBase -RObject forderForceBase(bool forceBase); -RcppExport SEXP _rxode2_forderForceBase(SEXP forceBaseSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< bool >::type forceBase(forceBaseSEXP); - rcpp_result_gen = Rcpp::wrap(forderForceBase(forceBase)); - return rcpp_result_gen; -END_RCPP -} // rxSetIni0 bool rxSetIni0(bool ini0); RcppExport SEXP _rxode2_rxSetIni0(SEXP ini0SEXP) { diff --git a/src/cvPost.cpp b/src/cvPost.cpp index b48f6cac2..a84247775 100644 --- a/src/cvPost.cpp +++ b/src/cvPost.cpp @@ -16,9 +16,6 @@ extern "C" { iniLotri; } -extern "C" SEXP chin(SEXP a, SEXP b); - - List etTrans(List inData, const RObject &mv, bool addCmt, bool dropUnits, bool allTimeVar, bool keepDosingOnly, Nullable combineDvid, @@ -653,11 +650,12 @@ SEXP expandTheta_(SEXP thetaS, SEXP thetaMatS, return as(ret); } - +Function getRxFn(std::string name); static inline int getMethodInt(std::string& methodStr, CharacterVector& allNames, SEXP et) { int methodInt=1; if (methodStr == "auto") { // FIXME don't use %in%/%chin% from R + Function chin = getRxFn(".chin"); LogicalVector inL = as(chin(allNames, Rf_getAttrib(et, R_NamesSymbol))); bool allIn = true; for (int j = inL.size(); j--;){ diff --git a/src/et.cpp b/src/et.cpp index f00ebe34d..0b02b89f3 100644 --- a/src/et.cpp +++ b/src/et.cpp @@ -14,6 +14,8 @@ extern "C" rx_solving_options op_global; using namespace Rcpp; +Function getRxFn(std::string name); + SEXP convertId_(SEXP id); extern "C" int _rxIsEt(SEXP objSexp); @@ -43,23 +45,11 @@ static inline bool rxIsCleanList(RObject obj) { #endif Environment rxode2env (); -Function getRxFn(std::string name); - -extern "C" SEXP getForder(void); -extern "C" int useForder(void); extern "C" SEXP orderForderS1(SEXP ordIn) { BEGIN_RCPP - Function order = getForder(); - IntegerVector ord; - if (useForder()){ - ord = order(ordIn, - _["na.last"] = LogicalVector::create(0)); - } else { - ord = order(ordIn, - _["na.last"] = LogicalVector::create(0), - _["method"]="radix"); - } + Function order1 = getRxFn(".order1"); + IntegerVector ord = order1(ordIn); return wrap(ord); END_RCPP } @@ -430,21 +420,13 @@ List etSort(List& curEt){ IntegerVector ivId=wrap(id); NumericVector nvTime=wrap(time); IntegerVector ivEvid=wrap(evid); - Function order = getForder(); + Function order3 = getRxFn(".order3"); IntegerVector ord; - if (useForder()){ - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(0)); - } else { - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(0), - _["method"]="radix"); - } + ord = order3(ivId, nvTime, ivEvid); ord = ord - 1; idx = as>(ord); List newEt(curEt.size()); int i, j, newSize = time.size(); - bool naTime=false; for (int j = time.size(); j--;) { if (ISNA(time[j])) { newSize--; @@ -592,16 +574,9 @@ List etAddWindow(List windowLst, IntegerVector IDs, RObject cmt, bool turnOnShow IntegerVector ivId=wrap(id); NumericVector nvTime=wrap(time); IntegerVector ivEvid=wrap(evid); - Function order = getForder(); + Function order3 = getRxFn(".order3"); IntegerVector ord; - if (useForder()){ - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL)); - } else { - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL), - _["method"]="radix"); - } + ord = order3(ivId, nvTime, ivEvid); ord = ord - 1; idx = as>(ord); List lst(curEt.size()); @@ -1531,16 +1506,9 @@ List etExpandAddl(List curEt){ IntegerVector ivId=wrap(id); NumericVector nvTime=wrap(time); IntegerVector ivEvid=wrap(evid); - Function order = getForder(); + Function order3 = getRxFn(".order3"); IntegerVector ord; - if (useForder()){ - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL)); - } else { - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL), - _["method"]="radix"); - } + ord = order3(ivId, nvTime, ivEvid); ord = ord - 1; idx = as>(ord); List lst(curEt.size()); @@ -1713,16 +1681,8 @@ List etAddDose(NumericVector curTime, RObject cmt, double amt, double rate, dou IntegerVector ivId=wrap(id); NumericVector nvTime=wrap(time); IntegerVector ivEvid=wrap(evid); - Function order = getForder(); - IntegerVector ord; - if (useForder()){ - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL)); - } else { - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL), - _["method"]="radix"); - } + Function order3 = getRxFn(".order3"); + IntegerVector ord = order3(ivId, nvTime, ivEvid); ord = ord - 1; idx = as>(ord); @@ -3147,6 +3107,8 @@ RObject et_(List input, List et__) { return ret; } +Function getRxFn(std::string name); + // Sequence event tables //[[Rcpp::export]] List etSeq_(List ets, int handleSamples=0, int waitType = 0, @@ -3386,16 +3348,9 @@ List etSeq_(List ets, int handleSamples=0, int waitType = 0, IntegerVector ivId=wrap(id); NumericVector nvTime=wrap(time); IntegerVector ivEvid=wrap(evid); - Function order = getForder(); + Function order3 = getRxFn(".order3"); IntegerVector ord; - if (useForder()){ - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL)); - } else { - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL), - _["method"]="radix"); - } + ord = order3(ivId, nvTime, ivEvid); ord = ord - 1; idx = as>(ord); } diff --git a/src/etTran.cpp b/src/etTran.cpp index aa2c3e4a6..d68868011 100644 --- a/src/etTran.cpp +++ b/src/etTran.cpp @@ -118,34 +118,8 @@ static inline bool asBool(SEXP in, const char *what) { } Function getRxFn(std::string name); -Environment rxode2env(); - -Environment dataTable; -bool getForder_b=false; -Function getRxFn(std::string name); -bool dtForder = false; -bool forderForceBase_ = false; -//' Force using base order for rxode2 radix sorting -//' -//' @param forceBase boolean indicating if rxode2 should use R's -//' [order()] for radix sorting instead of -//' `data.table`'s parallel radix sorting. -//' -//' @return NILL; called for side effects -//' -//' @examples -//' \donttest{ -//' forderForceBase(TRUE) # Use base `order` for rxode2 sorts -//' forderForceBase(FALSE) # Use `data.table` for rxode2 sorts -//' } -//' @export -//' @keywords internal -//[[Rcpp::export]] -RObject forderForceBase(bool forceBase = false){ - forderForceBase_=forceBase; - return R_NilValue; -} +Environment rxode2env(); IntegerVector convertDvid_(SEXP inCmt, int maxDvid=0){ IntegerVector id = asIv(inCmt, "inCmt"); @@ -156,42 +130,6 @@ IntegerVector convertDvid_(SEXP inCmt, int maxDvid=0){ } return id; } -extern "C" SEXP getForder(void) { - if (!getForder_b){ - Function fn = getRxFn(".getDTEnv"); - dataTable = fn(); - getForder_b=true; - } - if (!forderForceBase_ && dataTable.exists("forder")){ - dtForder=true; - return wrap(dataTable["forder"]); - } - Environment b=Rcpp::Environment::base_namespace(); - dtForder=false; - return wrap(b["order"]); -} - -Function getChin() { - if (!getForder_b){ - Function fn = getRxFn(".getDTEnv"); - dataTable = fn(); - getForder_b=true; - } - if (!forderForceBase_ && dataTable.exists("%chin%")){ - return dataTable["%chin%"]; - } - Environment b=Rcpp::Environment::base_namespace(); - return b["%in%"]; -} - -extern "C" SEXP chin(SEXP x, SEXP table) { - Function chin_ = getChin(); - return chin_(x, table); -} - -extern "C" int useForder(void){ - return (int)(getForder_b); -} IntegerVector toCmt(RObject inCmt, CharacterVector& state, const bool isDvid, const int stateSize, const int sensSize, IntegerVector& curDvid, @@ -2148,35 +2086,20 @@ List etTrans(List inData, const RObject &obj, bool addCmt=false, } } #undef sortID - Function order = as(getForder()); + Function order3 = getRxFn(".order3"); + Function order1 = getRxFn(".order1"); IntegerVector ord; IntegerVector ordI; - if (useForder()){ - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(true)); - ord = ord - 1; - // na.last isn't =NA isn't quite working - idxOutput = as>(ord); - while (idxOutput.size() > 0 && IntegerVector::is_na(ivId[idxOutput.back()])){ - idxOutput.pop_back(); - } - if (hasIcov) { - ordI = order(inIdCov, _["na.last"] = LogicalVector::create(true)); - ordI = ordI-1; - idxIcov = as>(ordI); - } - } else { - ord = order(ivId, nvTime, ivEvid, - _["na.last"] = LogicalVector::create(NA_LOGICAL), - _["method"]="radix"); - ord = ord - 1; - idxOutput = as>(ord); - if (hasIcov) { - ordI = order(inIdCov, _["na.last"] = LogicalVector::create(true), - _["method"]="radix"); - ordI = ordI-1; - idxIcov = as>(ordI); - } + ord = order3(ivId, nvTime, ivEvid); + ord = ord - 1; + idxOutput = as>(ord); + while (idxOutput.size() > 0 && IntegerVector::is_na(ivId[idxOutput.back()])){ + idxOutput.pop_back(); + } + if (hasIcov) { + ordI = order1(inIdCov); + ordI = ordI-1; + idxIcov = as>(ordI); } #ifdef rxSolveT REprintf(" Time8: %f\n", ((double)(clock() - _lastT0))/CLOCKS_PER_SEC); diff --git a/src/init.c b/src/init.c index 8227ae7fe..8d72b9e8b 100644 --- a/src/init.c +++ b/src/init.c @@ -283,8 +283,6 @@ extern rx_solving_options op_global; extern void setZeroMatrix(int which); extern void rxModelsAssignC(const char *str0, SEXP assign); -extern SEXP chin(SEXP x, SEXP table); - SEXP _rxode2_rxSolveSetup(void); SEXP _rxode2_etDollarNames(SEXP); @@ -334,7 +332,6 @@ SEXP _rxode2_rxQr(SEXP); SEXP _rxode2_parse_strncmpci(void); SEXP _rxode2_etTransEvidIsObs(SEXP); -SEXP _rxode2_forderForceBase(SEXP); SEXP _rxode2_rxSetIni0(SEXP ini0SEXP); SEXP _rxode2_rxEtTransAsDataFrame_(SEXP inData1SEXP); SEXP _rxode2_swapMatListWithCube_(SEXP inOSEXP); @@ -558,7 +555,6 @@ void R_init_rxode2(DllInfo *info){ {"_rxode2_swapMatListWithCube_", (DL_FUNC) &_rxode2_swapMatListWithCube_, 1}, {"_rxode2_rxEtTransAsDataFrame_", (DL_FUNC) &_rxode2_rxEtTransAsDataFrame_, 1}, {"_rxode2_rxSetIni0", (DL_FUNC) &_rxode2_rxSetIni0, 1}, - {"_rxode2_forderForceBase", (DL_FUNC) &_rxode2_forderForceBase, 1}, {"_rxode2_etTransEvidIsObs", (DL_FUNC) &_rxode2_etTransEvidIsObs, 1}, {"_rxode2_parse_strncmpci",(DL_FUNC) &_rxode2_parse_strncmpci, 0}, {"_rxode2_rxParseSetSilentErr", (DL_FUNC) &_rxode2_rxParseSetSilentErr, 1}, diff --git a/src/rxData.cpp b/src/rxData.cpp index 10d68a989..01ff397fc 100644 --- a/src/rxData.cpp +++ b/src/rxData.cpp @@ -72,8 +72,6 @@ extern "C" SEXP _rxode2_udfEnvSet(SEXP udf); extern "C" SEXP _rxode2_udfReset(); extern "C" SEXP _rxode2_rxC(SEXP in); -extern "C" SEXP getForder(void); -extern "C" int useForder(void); #include "../inst/include/rxode2_as.h" @@ -2840,15 +2838,8 @@ extern "C" void sortIds(rx_solve* rx, int ini) { ind = &(rx->subjects[i]); solveTime[i] = ind->solveTime; } - Function order = as(getForder()); - if (useForder()) { - ord = order(solveTime, _["na.last"] = LogicalVector::create(NA_LOGICAL), - _["decreasing"] = LogicalVector::create(true)); - } else { - ord = order(solveTime, _["na.last"] = LogicalVector::create(NA_LOGICAL), - _["method"]="radix", - _["decreasing"] = LogicalVector::create(true)); - } + Function order1 = getRxFn(".order1"); // decreasing + ord = order1(solveTime, _["decreasing"] = LogicalVector::create(true)); // This assumes that this has already been created std::copy(ord.begin(), ord.end(), rx->ordId); }