Test for trying to combine complex duplicate etas (errors)

nlmixr2 · Dec 2, 2023 · ae2dc6d · ae2dc6d
1 parent f883542
commit ae2dc6d
Show file tree

Hide file tree

Showing 2 changed files with 55 additions and 18 deletions.
diff --git a/R/ui-bind.R b/R/ui-bind.R
@@ -66,15 +66,19 @@ rxAppendModel_ <- function(model1, model2, common=TRUE) {
     # See if any of the items have covariances defined
     .complex1 <- which(vapply(.both, function(v) {
       .eta <- .ini1eta[.ini1eta$name == v, "neta1"]
-      any(.ini1eta$neta1 == .eta & .ini1eta$neta2 != .eta)
+      any((.ini1eta$neta1 == .eta & .ini1eta$neta2 != .eta) |
+            (.ini1eta$neta2 == .eta & .ini1eta$neta1 != .eta))
     }, logical(1), USE.NAMES = FALSE))
     .complex2 <- which(vapply(.both, function(v) {
-      .eta <- .ini1eta[.ini1eta$name == v, "neta1"]
-      any(.ini1eta$neta1 == .eta & .ini1eta$neta2 != .eta)
+      .eta <- .ini2eta[.ini2eta$name == v, "neta1"]
+      any((.ini2eta$neta1 == .eta & .ini2eta$neta2 != .eta) |
+            (.ini2eta$neta2 == .eta & .ini2eta$neta1 != .eta) )
     }, logical(1), USE.NAMES = FALSE))
     .err <- unique(c(.both[.complex1], .both[.complex2]))
     if (length(.err) > 0) {
-      stop("error")
+      stop("duplicated parameter has covariance, will not append models: '",
+           paste0(.err, collapse="', '"), "'",
+           call.=FALSE)
     } else {
       # drop in the second
       .minfo("duplicated eta parameters when combining 2 models")

diff --git a/tests/testthat/test-ui-mod-functions.R b/tests/testthat/test-ui-mod-functions.R
@@ -660,7 +660,7 @@ rxTest({
 
   })
 
-  test_that("bind together 2 models with etas with overlapping etas w/cov in 2", {
+  test_that("bind together 2 models with etas with overlapping etas w/cov in 1", {
 
     ocmt <- function() {
       ini({
@@ -704,21 +704,54 @@ rxTest({
       })
     }
 
-    m1 <- rxAppendModel(ocmt %>% model(ceff=cp,append=TRUE), idr)
+    expect_error(rxAppendModel(ocmt %>% model(ceff=cp,append=TRUE), idr))
+  })
 
-    expect_equal(m1$omega,
-                 lotri({
-                   eta.ka ~ 0.1
-                   eta.cl ~ 0.1
-                   eta.v ~ 0.1
-                   eta.kin ~ 0.1
-                   eta.kout ~ 0.1
-                   eta.ic50 ~ 0.1
-                 }))
+  test_that("bind together 2 models with etas with overlapping etas w/cov in 2", {
 
-    expect_equal(m1$theta,
-                 c(tka = 0.45, tcl = 1, tv = 3.45, add.sd = 0.7, tkin = 0, tkout = 0, tic50 = 2.30258509299405, gamma = 1, idr.sd = 1))
+    ocmt <- function() {
+      ini({
+        tka <- 0.45
+        tcl <- 1
+        tv <- 3.45
+        eta.ka ~ 0.1
+        eta.v  ~ 0.1
+        eta.cl ~ 0.1
+        add.sd <- 0.7
+      })
+      model({
+        ka <- exp(tka + eta.ka)
+        cl <- exp(tcl + eta.cl)
+        v <- exp(tv + eta.v)
+        d/dt(depot) = -ka * depot
+        d/dt(center) = ka * depot - cl / v * center
+        cp = center / v
+        cp ~ add(add.sd)
+      })
+    }
 
-  })
+    idr <- function() {
+      ini({
+        tkin <- log(1)
+        tkout <- log(1)
+        tic50 <- log(10)
+        gamma <- fix(1)
+        idr.sd <- 1
+        eta.kin ~ 0.1
+        eta.kout ~ 0.1
+        eta.ic50 + eta.v ~ c(0.1,
+                             0.001, 1)
+      })
+      model({
+        kin <- exp(tkin + eta.kin)
+        kout <- exp(tkout + eta.kout)
+        ic50 <- exp(tic50 + eta.ic50)
+        d/dt(eff) <- kin - kout*(1-ceff^gamma/(ic50^gamma+ceff^gamma) + eta.v)
+        eff ~ add(idr.sd)
+      })
+    }
+
+    expect_error(rxAppendModel(ocmt %>% model(ceff=cp,append=TRUE), idr))
 
+  })
 })