Merge pull request #308 from nlmixr2/306-simvpc-needs-to-more-closely…

…-match-the-estimated-model

Make some focei methods for simulation that are closer to est model

DESCRIPTION

@@ -101,4 +101,4 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 Language: en-US
 NeedsCompilation: yes
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.3

NAMESPACE

@@ -16,6 +16,12 @@ S3method(et,nlmixr2FitData)
 S3method(fixef,nlmixr2FitCore)
 S3method(fixef,nlmixr2FitCoreSilent)
 S3method(fixef,saemFit)
+S3method(getBaseSimModelFit,default)
+S3method(getBaseSimModelFit,fo)
+S3method(getBaseSimModelFit,foce)
+S3method(getBaseSimModelFit,focei)
+S3method(getBaseSimModelFit,foi)
+S3method(getBaseSimModelFit,posthoc)
 S3method(getData,nlmixr2FitCore)
 S3method(getData,nlmixr2FitCoreSilent)
 S3method(getValidNlmixrCtl,default)
@@ -113,6 +119,7 @@ S3method(nmObjGet,saemTransformedData)
 S3method(nmObjGet,seed)
 S3method(nmObjGet,sigma)
 S3method(nmObjGet,simInfo)
+S3method(nmObjGet,simulationModel)
 S3method(nmObjGet,ui)
 S3method(nmObjGet,warnings)
 S3method(nmObjGetControl,default)
@@ -297,6 +304,7 @@ export(foceiControl)
 export(foceiFitCpp_)
 export(geom_amt)
 export(geom_cens)
+export(getBaseSimModelFit)
 export(getData)
 export(getOfvType)
 export(getValidNlmixrControl)

R/fitSim.R

@@ -0,0 +1,112 @@
+#' Method for getting simulation rxode2 classic models based on fits
+#'
+#' @param x list where first element is the fit.  The class represents the estimation method.
+#' @return  model for fit$simulationModel
+#' @author Matthew L. Fidler
+#' @export
+#' @keywords internal
+getBaseSimModelFit <- function(x) {
+  UseMethod("getBaseSimModelFit")
+}
+
+.isAssignExpr <- function(x) {
+  length(x) == 3L &&
+    (identical(x[[1]],quote(`=`)) ||
+       identical(x[[1]],quote(`<-`)))
+}
+
+.replaceThetaEtaWithNamed <- function(x, iniDf) {
+  if (is.call(x)) {
+    if (length(x) == 3L &&
+          is.numeric(x[[3]]) &&
+          identical(x[[1]], quote(`[`))) {
+      if (identical(x[[2]], quote(`THETA`))) {
+        return(str2lang(iniDf[which(iniDf$ntheta== x[[3]]), "name"]))
+      }
+      if (identical(x[[2]], quote(`ETA`))) {
+        return(str2lang(iniDf[which(iniDf$neta1 == x[[3]] & iniDf$neta2 == x[[3]]),
+                              "name"]))
+      }
+    }
+    return(as.call(lapply(x, .replaceThetaEtaWithNamed, iniDf)))
+  }
+  x
+}
+
+#' @rdname getBaseSimModelFit
+#' @export
+getBaseSimModelFit.focei <- function(x) {
+  obj <- x[[1]]
+  if (all(obj$ui$predDf$distribution == "norm")) {
+    .expr <- eval(parse(text=paste0("quote(rxode2({",
+                                    rxode2::rxNorm(obj$foceiModel$predOnly),
+                                    "}))")))
+    .e2 <- .expr[[2]]
+    .e2 <- lapply(seq_along(.e2), function(i) {
+      .cur <- .e2[[i]]
+      .replaceThetaEtaWithNamed(.cur, obj$ui$iniDf)
+    })
+    .w <- vapply(seq_along(.e2), function(i) {
+      .cur <- .e2[[i]]
+      if (.isAssignExpr(.cur) &&
+            identical(.cur[[2]], .cur[[3]])) {
+        return(FALSE)
+      }
+      return(TRUE)
+    }, logical(1), USE.NAMES=FALSE)
+    .e2 <- .e2[.w]
+    .w <- which(vapply(seq_along(.e2), function(i) {
+      .cur <- .e2[[i]]
+      if (.isAssignExpr(.cur) &&
+            identical(.cur[[2]], quote(`rx_r_`))) return(TRUE)
+      FALSE
+    }, logical(1), USE.NAMES=TRUE))
+    .w <- seq(1, .w)
+    .e21 <- .e2[.w]
+    .e22 <- .e2[-.w]
+    .e2 <- as.call(c(.e21,
+      list(quote(ipredSim <- rxTBSi(rx_pred_, rx_lambda_, rx_yj_, rx_low_, rx_hi_)),
+           eval(parse(text=paste0("quote(sim <- rxTBSi(rx_pred_ + sqrt(rx_r_) *(",
+                                  paste(paste0("error.", obj$predDf$var, "*(CMT==", obj$predDf$cmt, ")"),
+                                        collapse = "+"),
+                                  "), rx_lambda_, rx_yj_, rx_low_, rx_hi_))")))),
+      .e22))
+    .expr[[2]] <- .e2
+
+
+  }
+  getBaseSimModelFit.default(x)
+}
+
+#' @rdname getBaseSimModelFit
+#' @export
+getBaseSimModelFit.foce <- getBaseSimModelFit.focei
+
+#' @rdname getBaseSimModelFit
+#' @export
+getBaseSimModelFit.fo <- getBaseSimModelFit.focei
+#' @rdname getBaseSimModelFit
+#' @export
+getBaseSimModelFit.foi <- getBaseSimModelFit.focei
+
+#' @rdname getBaseSimModelFit
+#' @export
+getBaseSimModelFit.posthoc <- getBaseSimModelFit.focei
+
+#' @rdname getBaseSimModelFit
+#' @export
+getBaseSimModelFit.default <- function(x) {
+  .obj <- x[[1]]
+  .ui <- .obj$ui
+  rxode2::getBaseSimModel(.ui)
+}
+
+getBaseSimModel.nlmixr2FitCoreSilent <- function(obj) {
+  .est <- obj$est
+  .ret <- list(obj)
+  class(.ret) <- c(.est, "getBaseSimModelFit")
+  return(getBaseSimModelFit(.ret))
+}
+
+getBaseSimModel.nlmixr2FitData <- getBaseSimModel.nlmixr2FitCoreSilent
+getBaseSimModel.nlmixr2FitCore <- getBaseSimModel.nlmixr2FitCoreSilent

R/nmObjGet.R

@@ -882,6 +882,12 @@ nmObjGetRxSolve.default <- function(x, what) {
   .lst[[what]]
 }
 
+#' @rdname nmObjGet
+#' @export
+nmObjGet.simulationModel <- function(x, ...) {
+  eval(rxode2::getBaseSimModel(x[[1]]))
+}
+
 #' @rdname nmObjGet
 #' @export
 nmObjGet.rxControl <- function(x, ...) {

R/onLoad.R

@@ -26,6 +26,9 @@
   }
   rxode2::.s3register("rxode2::rxModelVarsS3", "nlmixr2FitCore")
   rxode2::.s3register("rxode2::rxModelVarsS3", "nlmixr2FitCoreSilent")
+  rxode2::.s3register("rxode2::getBaseSimModel", "nlmixr2FitCoreSilent")
+  rxode2::.s3register("rxode2::getBaseSimModel", "nlmixr2FitCore")
+  rxode2::.s3register("rxode2::getBaseSimModel", "nlmixr2FitData")
   .resetCacheIfNeeded()
 }
 

R/simulate.R

@@ -53,7 +53,7 @@
 #' @author Matthew L. Fidler
 #' @noRd
 .getSimModel <- function(obj, hideIpred=FALSE, tad=TRUE) {
-  .lines <- rxode2::rxCombineErrorLines(obj$ui)
+  .lines <- rxode2::getBaseSimModel(obj)
   .f <- function(x) {
     if (is.atomic(x) || is.name(x) || is.pairlist(x)) {
       return(x)