Merge remote-tracking branch 'origin/main' into 728-wnl-style-linear-…

…compartment-models-using-combined-rxode2

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: rxode2
-Version: 3.0.2
+Version: 3.0.2.9000
 Title: Facilities for Simulating from ODE-Based Models
 Authors@R: c(
    person("Matthew L.","Fidler", role = c("aut", "cre"), email = "matthew.fidler@gmail.com", comment=c(ORCID="0000-0001-8538-6691")),

NAMESPACE

@@ -583,6 +583,7 @@ export(rxTick)
 export(rxToSE)
 export(rxTrans)
 export(rxUdfUi)
+export(rxUdfUiControl)
 export(rxUdfUiData)
 export(rxUdfUiEst)
 export(rxUdfUiIniDf)

NEWS.md

@@ -1,3 +1,12 @@
+# rxode2 (development version)
+
+- Add `getRxNpars` to api.  This allows the development version of
+  `babelmixr2` to better check what model is loaded and unload/reload
+  as necessary.
+
+- Add `rxUdfUiControl()` to rxode2 user function to get control
+  information from something like `nlmixr2`
+
 # rxode2 3.0.2
 
 - Bug fix for `api`, the censoring function pointer has been updated

R/err-foceiBase.R

@@ -323,14 +323,14 @@
 #' Handle the single error for normal or t distributions
 #'
 #' @param env Environment for the parsed model
-#' 
+#'
 #' @param pred1 The `data.frame` of the current error
 #'
 #' @param errNum The number of the error specification in the nlmixr2 model
-#' 
+#'
 #' @param rxPredLlik A boolean indicating if the log likelihood should
 #'   be calculated for non-normal distributions.  By default `TRUE`.
-#' 
+#'
 #' @return A list of the lines added.  The lines will contain
 #'
 #' - `rx_yj_` which is an integer that corresponds to the
@@ -347,7 +347,7 @@
 #' - `rx_pred_` The transformed prediction function
 #'
 #' - `rx_r_` The transformed variance
-#' 
+#'
 #' @author Matthew Fidler
 #' @export
 .handleSingleErrTypeNormOrTFoceiBase <- function(env, pred1, errNum=1L, rxPredLlik=TRUE) {
@@ -474,7 +474,7 @@
     .first <- vapply(seq(2, length(.c)), function(i) {
       paste0("(DV==",(i-1),")*(",
              deparse1(.c[[i]]),")")
-      
+
     }, character(1), USE.NAMES=FALSE)
     .last <- vapply(seq(2, length(.c)), function(i) {
       paste0("(", deparse1(.c[[i]]), ")")

R/et.R

@@ -1324,48 +1324,46 @@ c.rxEvid <- function(x, ...) {
 }
 .colorFmt.rxEvid <- function(x, ...) {
   .x <- unclass(x)
-  .x <-
-    ifelse(.x == 0, paste0(crayon::blue$bold("0"), ":", crayon::white("Observation")),
-      ifelse(.x == 1, paste0(crayon::blue$bold("1"), ":", crayon::yellow("Dose (Add)")),
-        ifelse(.x == 2, paste0(crayon::blue$bold("2"), ":", crayon::yellow("Other")),
-          ifelse(.x == 3, paste0(crayon::blue$bold("3"), ":", crayon::red("Reset")),
-            ifelse(.x == 4, paste0(crayon::blue$bold("4"), ":", crayon::red("Reset"), "&", crayon::yellow("Dose")),
-              ifelse(.x == 5, paste0(crayon::blue$bold("5"), ":", crayon::red("Replace")),
-                ifelse(.x == 6, paste0(crayon::blue$bold("6"), ":", crayon::yellow("Multiply")),
-                  ifelse(.x == 7, paste0(crayon::blue$bold("7"), ":", crayon::yellow("Transit")),
-                  paste0(crayon::blue$red(.x), ":", crayon::red("Invalid")))
-                )
-              )
-            )
-          )
-        )
+  if (is.numeric(.x)) {
+    .x <-
+      data.table::fcase(
+        .x == 0, paste0(crayon::blue$bold("0"), ":", crayon::white("Observation")),
+        .x == 1, paste0(crayon::blue$bold("1"), ":", crayon::yellow("Dose (Add)")),
+        .x == 2, paste0(crayon::blue$bold("2"), ":", crayon::yellow("Other")),
+        .x == 3, paste0(crayon::blue$bold("3"), ":", crayon::red("Reset")),
+        .x == 4, paste0(crayon::blue$bold("4"), ":", crayon::red("Reset"), "&", crayon::yellow("Dose")),
+        .x == 5, paste0(crayon::blue$bold("5"), ":", crayon::red("Replace")),
+        .x == 6, paste0(crayon::blue$bold("6"), ":", crayon::yellow("Multiply")),
+        .x == 7, paste0(crayon::blue$bold("7"), ":", crayon::yellow("Transit")),
+        default=paste0(crayon::blue$red(.x), ":", crayon::red("Invalid"))
       )
-    )
-  return(format(.x, justify = "left"))
+  } else {
+    .x <- paste0(crayon::blue$red(.x), ":", crayon::red("Invalid"))
+  }
+  format(.x, justify = "left")
 }
 
 #' @rdname rxEvid
 #' @export
 as.character.rxEvid <- function(x, ...) {
   .x <- unclass(x)
-  .x <-
-    ifelse(.x == 0, "0:Observation",
-      ifelse(.x == 1, "1:Dose (Add)",
-        ifelse(.x == 2, "2:Other",
-          ifelse(.x == 3, "3:Reset",
-            ifelse(.x == 4, "4:Reset&Dose",
-              ifelse(.x == 5, "5:Replace",
-                ifelse(.x == 6, "6:Multiply",
-                  ifelse(.x == 7, "7:Transit",
-                         paste0(.x, ":Invalid"))
-                )
-              )
-            )
-          )
-        )
+  if (is.numeric(.x)) {
+    .x <-
+      data.table::fcase(
+        .x == 0, "0:Observation",
+        .x == 1, "1:Dose (Add)",
+        .x == 2, "2:Other",
+        .x == 3, "3:Reset",
+        .x == 4, "4:Reset&Dose",
+        .x == 5, "5:Replace",
+        .x == 6, "6:Multiply",
+        .x == 7, "7:Transit",
+        default = paste0(.x, ":Invalid")
       )
-    )
-  return(.x)
+  } else {
+    .x <- paste0(.x, ":Invalid")
+  }
+  .x
 }
 
 

R/rudfui.R

@@ -15,6 +15,7 @@ rxUdfUiReset <- function() {
   .udfUiEnv$lhs <- NULL
   .udfUiEnv$data <- NULL
   .udfUiEnv$est <- NULL
+  .udfUiEnv$control <- NULL
   .udfUiEnv$parsing <- FALSE
   .udfUiEnv$mv <- NULL
   invisible(NULL)
@@ -133,6 +134,35 @@ rxUdfUiData <- function(value) {
          call.=FALSE)
   }
 }
+
+#' Return the control that is being processed or setup control for processing
+#'
+#' @param value when specified, this assigns the control to be
+#'   processed, or resets it by assigning it to be `NULL`.
+#'
+#' @return value of the `data.frame` being processed or `NULL`.
+#'
+#' @export
+#' @family User functions
+#' @author Matthew L. Fidler
+#' @examples
+#'
+#' rxUdfUiControl()
+#'
+rxUdfUiControl <- function(value) {
+  if (missing(value)) {
+    .udfUiEnv$control
+  } else if (is.list(value)) {
+    .udfUiEnv$control <- value
+  } else if (is.null(value)) {
+    .udfUiEnv$control <- value
+  } else {
+    stop("rxUdfUiControl must be called with a list, NULL, or without any arguments",
+         call.=FALSE)
+  }
+  invisible(.udfUiEnv$control)
+
+}
 #' Return the current estimation method for the UI processing
 #'
 #' @param value when specified, this assigns the character value of

_pkgdown.yml

@@ -166,6 +166,7 @@ reference:
   - linMod
   - rxIntToBase
   - rxIntToLetter
+  - rxUdfUiControl
   - rxUdfUiData
   - rxUdfUiEst
   - rxUdfUiIniDf

inst/include/rxode2ptr.h

@@ -164,6 +164,9 @@ extern "C" {
   typedef double * (*getOpIndSolve_t)(rx_solving_options* op, rx_solving_options_ind* ind, int idx);
   extern getOpIndSolve_t getOpIndSolve;
 
+  typedef int (*getRxNpars_t)(rx_solve *rx);
+  extern getRxNpars_t getRxNpars;
+
   static inline SEXP iniRxodePtrs0(SEXP p) {
     if (_rxode2_rxRmvnSEXP_ == NULL) {
       _rxode2_rxRmvnSEXP_ = (_rxode2_rxRmvnSEXP_t) R_ExternalPtrAddrFn(VECTOR_ELT(p, 0));
@@ -214,6 +217,7 @@ extern "C" {
       getRxNobs = (getRxNobs_t) R_ExternalPtrAddrFn(VECTOR_ELT(p, 45));
       getRxNobs2 = (getRxNobs2_t) R_ExternalPtrAddrFn(VECTOR_ELT(p, 46));
       getOpIndSolve = (getOpIndSolve_t) R_ExternalPtrAddrFn(VECTOR_ELT(p, 47));
+      getRxNpars = (getRxNpars_t) R_ExternalPtrAddrFn(VECTOR_ELT(p, 48));
     }
     return R_NilValue;
   }
@@ -267,6 +271,7 @@ extern "C" {
   getRxNobs_t getRxNobs = NULL;                         \
   getRxNobs2_t getRxNobs2 = NULL;                       \
   getOpIndSolve_t getOpIndSolve = NULL;                 \
+  getRxNpars_t getRxNpars = NULL;                       \
   SEXP iniRxodePtrs(SEXP ptr) {                         \
     return iniRxodePtrs0(ptr);                          \
   }                                                     \

inst/tools/workaround.R

@@ -47,21 +47,22 @@ if (length(w) >= 1) {
 
 
 
-
-if (.Platform$OS.type == "windows" && !file.exists("src/Makevars.win")) {
-  .in <- gsub("@CXX14STD@", "-std=c++1y", .in)
-  file.out <- file("src/Makevars.win", "wb")
-  writeLines(gsub("@ISYSTEM@", "I", .in),
-             file.out)
-  close(file.out)
+if (.Platform$OS.type == "windows") {
+  .makevars <- file("src/Makevars.win", "wb")
+  .i <- "I"
 } else {
-  .in <- gsub("@CXX14STD@", "-std=gnu++14", .in)
-  file.out <- file("src/Makevars", "wb")
-  writeLines(gsub("@ISYSTEM@", "isystem", .in),
-             file.out)
-  close(file.out)
+  .makevars <- file("src/Makevars", "wb")
+  if (any(grepl("Pop!_OS", utils::osVersion, fixed=TRUE))) {
+    .i <- "isystem"
+  } else {
+    .i <- "I"
+  }
 }
 
+writeLines(gsub("@ISYSTEM@", .i, .in),
+             .makevars)
+close(.makevars)
+
 if (file.exists("man/reexports.Rd")) {
   l <- readLines("man/reexports.Rd")
   if (!any(regexpr("[\\]value", l) != -1)) {

src/init.c

@@ -428,9 +428,11 @@ SEXP _rxode2_rxode2Ptr(void) {
   SEXP rxode2getRxNobs = PROTECT(R_MakeExternalPtrFn((DL_FUNC)&getRxNobs, R_NilValue, R_NilValue)); pro++;
   SEXP rxode2getRxNobs2 = PROTECT(R_MakeExternalPtrFn((DL_FUNC)&getRxNobs2, R_NilValue, R_NilValue)); pro++;
   SEXP rxode2getOpIndSolve = PROTECT(R_MakeExternalPtrFn((DL_FUNC)&getOpIndSolve, R_NilValue, R_NilValue)); pro++;
+  SEXP rxode2getRxNpars = PROTECT(R_MakeExternalPtrFn((DL_FUNC)&getRxNpars,
+                                                      R_NilValue, R_NilValue)); pro++;
 
 
-#define nVec 48
+#define nVec 49
 
   SEXP ret = PROTECT(Rf_allocVector(VECSXP, nVec)); pro++;
   SET_VECTOR_ELT(ret, 0, rxode2rxRmvnSEXP);
@@ -481,6 +483,7 @@ SEXP _rxode2_rxode2Ptr(void) {
   SET_VECTOR_ELT(ret, 45, rxode2getRxNobs);
   SET_VECTOR_ELT(ret, 46, rxode2getRxNobs2);
   SET_VECTOR_ELT(ret, 47, rxode2getOpIndSolve);
+  SET_VECTOR_ELT(ret, 48, rxode2getRxNpars);
 
   SEXP retN = PROTECT(Rf_allocVector(STRSXP, nVec)); pro++;
   SET_STRING_ELT(retN, 0, Rf_mkChar("rxode2rxRmvnSEXP"));
@@ -531,7 +534,7 @@ SEXP _rxode2_rxode2Ptr(void) {
   SET_STRING_ELT(retN, 45, Rf_mkChar("rxode2getRxNobs"));
   SET_STRING_ELT(retN, 46, Rf_mkChar("rxode2getRxNobs2"));
   SET_STRING_ELT(retN, 47, Rf_mkChar("rxode2getOpIndSolve"));
-
+  SET_STRING_ELT(retN, 48, Rf_mkChar("rxode2getRxNpars"));
 #undef nVec
 
   // Set the names attribute of the list

src/rx2api.c

@@ -185,6 +185,10 @@ int getRxNobs(rx_solve *rx) {
 int getRxNobs2(rx_solve *rx) {
   return rx->nobs2;
 }
+
+int getRxNpars(rx_solve *rx) {
+  return rx->npars;
+}
 ////////////////////////////////////////////////////////////////////////
 // Get solve vector for ith solve
 ////////////////////////////////////////////////////////////////////////