Merge pull request #791 from nlmixr2/790-new-data-table

New data.table interface

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

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)

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
+}

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) {

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) {

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<LogicalVector> combineDvid,
@@ -653,11 +650,12 @@ SEXP expandTheta_(SEXP thetaS, SEXP thetaMatS,
   return as<SEXP>(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<LogicalVector>(chin(allNames, Rf_getAttrib(et, R_NamesSymbol)));
     bool allIn = true;
     for (int j = inL.size(); j--;){

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<std::vector<int>>(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<std::vector<int>>(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<std::vector<int>>(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<std::vector<int>>(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<std::vector<int>>(ord);
   }