test/fix multiple endpoint iwres model

nlmixr2 · May 12, 2023 · 096bec0 · 096bec0
1 parent ab61096
commit 096bec0
Show file tree

Hide file tree

Showing 2 changed files with 103 additions and 2 deletions.
diff --git a/R/rxUiGet.R b/R/rxUiGet.R
@@ -8,8 +8,23 @@ rxUiGet.simulationModelIwres <- function(x, ...) {
     .env$.ui <- .ui
     .ui <- with(.env,eval(rxode2::rxCombineErrorLines(.ui, modelVars=TRUE)))
     DV <- sim <- iwres <- rxdv <- rx_pred_ <- rx_r_ <- NULL
-    .ret <- suppressMessages(rxode2::model(.ui, iwres <- (DV-rx_pred_)/sqrt(rx_r_),
-                                           append=sim, auto=FALSE))
+    if (length(.ui$predDf$cond) == 1) {
+      .ret <- suppressMessages(rxode2::model(.ui, iwres <- (DV-rx_pred_)/sqrt(rx_r_),
+                                             append=sim, auto=FALSE))
+    } else {
+      .ret <- suppressMessages(rxode2::as.rxUi(.ui))
+      .lstExpr <- .ret$lstExpr
+      .l <- length(.lstExpr)
+      while(identical(.lstExpr[[.l]][[1]], quote(`dvid`)) ||
+              identical(.lstExpr[[.l]][[1]], quote(`cmt`))) .l <- .l - 1
+      .lstOut <- c(list(quote(`{`)),
+                   lapply(seq_len(.l), function(i) .lstExpr[[i]]),
+                    list(quote(iwres <- (DV-rx_pred_)/sqrt(rx_r_))),
+                   lapply(seq(.l+1, length(.lstExpr)), function(i) .lstExpr[[i]]))
+      .lstOut <- as.call(list(quote(`model`), as.call(.lstOut)))
+      rxode2::model(.ret) <- .lstOut
+      .ret
+    }
     .ret <- rxode2::rxModelVars(.ret)
     .ret <- rxode2(.ret)
     .ret

diff --git a/tests/testthat/test-sim-iwres.R b/tests/testthat/test-sim-iwres.R
@@ -0,0 +1,86 @@
+test_that("test $simulationModelIwres with multiple endpoints", {
+  pk.turnover.emax3 <- function() {
+    ini({
+      tktr <- log(1)
+      tka <- log(1)
+      tcl <- log(0.1)
+      tv <- log(10)
+      ##
+      eta.ktr ~ 1
+      eta.ka ~ 1
+      eta.cl ~ 2
+      eta.v ~ 1
+      prop.err <- 0.1
+      pkadd.err <- 0.1
+      ##
+      temax <- logit(0.8)
+      tec50 <- log(0.5)
+      tkout <- log(0.05)
+      te0 <- log(100)
+      ##
+      eta.emax ~ .5
+      eta.ec50  ~ .5
+      eta.kout ~ .5
+      eta.e0 ~ .5
+      ##
+      pdadd.err <- 10
+    })
+    model({
+      ktr <- exp(tktr + eta.ktr)
+      ka <- exp(tka + eta.ka)
+      cl <- exp(tcl + eta.cl)
+      v <- exp(tv + eta.v)
+      emax = expit(temax+eta.emax)
+      ec50 =  exp(tec50 + eta.ec50)
+      kout = exp(tkout + eta.kout)
+      e0 = exp(te0 + eta.e0)
+      ##
+      DCP = center/v
+      PD=1-emax*DCP/(ec50+DCP)
+      ##
+      effect(0) = e0
+      kin = e0*kout
+      ##
+      d/dt(depot) = -ktr * depot
+      d/dt(gut) =  ktr * depot -ka * gut
+      d/dt(center) =  ka * gut - cl / v * center
+      d/dt(effect) = kin*PD -kout*effect
+      ##
+      cp = center / v
+      cp ~ prop(prop.err) + add(pkadd.err)
+      effect ~ add(pdadd.err) | pca
+    })
+  }
+
+  mod <- pk.turnover.emax3()
+
+  expect_true(inherits(mod$simulationModelIwres, "rxode2"))
+})
+
+test_that("test $simulationModelIwres with single endpoints", {
+  one.cmt <- function() {
+    ini({
+      ## You may label each parameter with a comment
+      tka <- 0.45 # Ka
+      tcl <- log(c(0, 2.7, 100)) # Log Cl
+      ## This works with interactive models
+      ## You may also label the preceding line with label("label text")
+      tv <- 3.45; label("log V")
+      ## the label("Label name") works with all models
+      eta.ka ~ 0.6
+      eta.cl ~ 0.3
+      eta.v ~ 0.1
+      add.sd <- 0.7
+    })
+    model({
+      ka <- exp(tka + eta.ka)
+      cl <- exp(tcl + eta.cl)
+      v <- exp(tv + eta.v)
+      linCmt() ~ add(add.sd)
+    })
+  }
+
+  mod <- one.cmt()
+
+  expect_true(inherits(mod$simulationModelIwres, "rxode2"))
+})