Start merging rxode2parse

DESCRIPTION

@@ -117,7 +117,11 @@ LinkingTo:
     PreciseSums (>= 0.3),
     Rcpp,
     RcppArmadillo (>= 0.9.300.2.0),
-    BH
+    BH,
+    RcppParallel,
+    RcppEigen (>= 0.3.3.9.2),
+    StanHeaders (>= 2.21.0.7),
+    dparser
 Encoding: UTF-8
 LazyData: true
 Language: en-US

R/RcppExports.R

@@ -116,11 +116,47 @@ 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
+#'   zero. Otherwise the initial conditions are the first observed
+#'   time.
+#'
+#' @return the boolean ini0, though this is called for its side effects
+#'
+#' @export
+rxSetIni0 <- function(ini0 = TRUE) {
+    .Call(`_rxode2_rxSetIni0`, ini0)
+}
+
+etTransEvidIsObs <- function(isObsSexp) {
+    .Call(`_rxode2_etTransEvidIsObs`, isObsSexp)
+}
+
 #' Event translation for rxode2
 #'
 #' @param inData Data frame to translate
 #'
-#' @param obj Model to translate data
+#' @param mv Model variables to translate data
 #'
 #' @param addCmt Add compartment to data frame (default `FALSE`).
 #'
@@ -139,15 +175,29 @@ etRep_ <- function(curEt, times, wait, ids, handleSamples, waitType, ii) {
 #' @param keep This is a named vector of items you want to keep in the final rxode2 dataset.
 #'     For added rxode2 event records (if seen), last observation carried forward will be used.
 #'
-#' @inheritParams rxode2parse::etTransParse
+#' @param addlKeepsCov This determines if the additional dosing items
+#'   repeats the dose only (`FALSE`) or keeps the covariates at the
+#'   record of the dose (`TRUE`)
+#'
+#' @param addlDropSs When there are steady state doses with an `addl`
+#'   specification the steady state flag is dropped with repeated
+#'   doses (when `TRUE`) or retained (when `FALSE`)
+#'
+#' @param ssAtDoseTime Boolean that when `TRUE` back calculates the
+#'   steady concentration at the actual time of dose, otherwise when
+#'   `FALSE` the doses are shifted
 #'
 #' @return Object for solving in rxode2
 #'
 #' @keywords internal
 #'
 #' @export
-etTrans <- function(inData, obj, addCmt = FALSE, dropUnits = FALSE, allTimeVar = FALSE, keepDosingOnly = FALSE, combineDvid = NULL, keep = character(0), addlKeepsCov = FALSE, addlDropSs = TRUE, ssAtDoseTime = TRUE) {
-    .Call(`_rxode2_etTrans`, inData, obj, addCmt, dropUnits, allTimeVar, keepDosingOnly, combineDvid, keep, addlKeepsCov, addlDropSs, ssAtDoseTime)
+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)
+}
+
+rxEtTransAsDataFrame_ <- function(inData1) {
+    .Call(`_rxode2_rxEtTransAsDataFrame_`, inData1)
 }
 
 #' Expand grid internal function
@@ -243,6 +293,33 @@ rxIndLin_ <- function(states) {
     .Call(`_rxode2_rxIndLin_`, states)
 }
 
+convertId_ <- function(x) {
+    .Call(`_rxode2_convertId_`, x)
+}
+
+rxQs <- function(x) {
+    .Call(`_rxode2_rxQs`, x)
+}
+
+rxQr <- function(encoded_string) {
+    .Call(`_rxode2_rxQr`, encoded_string)
+}
+
+rxode2parseSetRstudio <- function(isRstudio = FALSE) {
+    .Call(`_rxode2_rxode2parseSetRstudio`, isRstudio)
+}
+
+#' Silence some of rxode2's C/C++ messages
+#'
+#' @param silent can be 0L "noisy"  or 1L "silent"
+#'
+#' @keywords internal
+#' @return TRUE; called for side effects
+#' @export
+rxParseSetSilentErr <- function(silent) {
+    .Call(`_rxode2_rxParseSetSilentErr`, silent)
+}
+
 #' Check the type of an object using Rcpp
 #'
 #' @param obj Object to check

inst/include/rxode2_RcppExports.h

@@ -6,6 +6,7 @@
 #ifndef RCPP_rxode2_RCPPEXPORTS_H_GEN_
 #define RCPP_rxode2_RCPPEXPORTS_H_GEN_
 
+#include <RcppEigen.h>
 #include <Rcpp.h>
 
 namespace rxode2 {

inst/include/rxode2parse.h

@@ -0,0 +1,76 @@
+#pragma once
+#define STRICT_R_HEADERS
+#ifndef __rxode2parse_H__
+#define __rxode2parse_H__
+#define rxLlikSaveSize 9
+
+#define getAdvan(idx) ind->solve + (op->neq + op->nlin)*(idx) + op->neq
+#define getSolve(idx) ind->solve + (op->neq + op->nlin)*(idx)
+#define isDose(evid) ((evid) == 3 || (evid) >= 100)
+#define isObs(evid) ((evid) == 0 || (evid) == 2 || ((evid) >= 9 && (evid) <= 99))
+
+#define getEvid(ind, idx) (idx >= 0 ? ind->evid[idx] : ind->extraDoseEvid[-1-idx])
+#define getEvidP1(ind, idx) (idx >= 0 ? ind->evid[idx+1] : ind->extraDoseEvid[-idx])
+#define getEvidM1(ind, idx) (idx >= 0 ? ind->evid[idx-1] : ind->extraDoseEvid[-2-idx])
+
+#define getDose(ind, idx) (idx >= 0 ? ind->dose[idx] : ind->extraDoseDose[-1-idx])
+#define getDoseP1(ind, idx) (idx >= 0 ? ind->dose[idx+1] : ind->extraDoseDose[-idx])
+#define getDoseM1(ind, idx) (idx >= 0 ? ind->dose[idx-1] : ind->extraDoseDose[-2-idx])
+
+#define setDoseP1(ind, idx, val) if (idx >= 0){ind->dose[idx+1] = val;} else {ind->extraDoseDose[-idx] = val;}
+
+#define getIi(ind, idx) (idx >= 0 ? ind->ii[idx] : 0.0)
+#define getIiP1(ind, idx) (idx >= 0 ? ind->ii[idx+1] : 0.0)
+#define getIiM1(ind, idx) (ind >= 0 ? ind->ii[idx-1] : 0.0)
+
+#define getDoseM1(ind, idx) (idx >= 0 ? ind->dose[idx-1] : ind->extraDoseDose[-2-idx])
+
+#define getAllTimes(ind, idx) (idx >= 0 ? ind->all_times[idx] : ind->extraDoseTime[-1-idx])
+#define getAllTimesP1(ind, idx) (idx >= 0 ? ind->all_times[idx+1] : ind->extraDoseTime[-idx])
+#define getAllTimesM1(ind, idx) (idx >= 0 ? ind->all_times[idx-1] : ind->extraDoseTime[-2-idx])
+
+#define setAllTimesP1(ind, idx, val) if (idx>= 0) {ind->all_times[idx+1] = val;} else {ind->extraDoseTime[-idx] = val;}
+#include <R.h>
+#include <stdbool.h>
+
+#include <float.h>
+#include <stdio.h>
+#include <stdarg.h>
+
+#include "rxode2parse_control.h"
+#include <stdint.h>    // 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

inst/include/rxode2parseConvertMethod.h

@@ -0,0 +1,57 @@
+#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<std::string>(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<std::string>(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<std::string>(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<std::string>(lvl[jj])).c_str());
+      }
+    }
+    for (int jj = tmp.size(); jj--;){
+      oldEvid[jj] = trans[tmp[jj]-1];
+    }
+  } else if (rxIsNumInt(method)){
+    IntegerVector tmp = as<IntegerVector>(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