Merge pull request #751 from nlmixr2/751-linCmt-test-assert

Create a function that asserts/tests that the model is a linear compartment model

NAMESPACE

@@ -311,6 +311,7 @@ export(assertCompartmentName)
 export(assertCompartmentNew)
 export(assertExists)
 export(assertParameterValue)
+export(assertRxLinCmt)
 export(assertRxUi)
 export(assertRxUiEstimatedResiduals)
 export(assertRxUiMixedOnly)
@@ -568,6 +569,7 @@ export(stat_cens)
 export(swapMatListWithCube)
 export(testCompartmentExists)
 export(testExists)
+export(testRxLinCmt)
 export(testVariableExists)
 export(toTrialDuration)
 export(uppergamma)

R/assert.R

@@ -85,6 +85,60 @@ assertRxUi <- function(ui, extra="", .var.name=.vname(ui)) {
   }
   invisible(ui)
 }
+#' Test if rxode2 uses linear solved systems
+#'
+#' @param ui rxode2 model
+#' @inheritParams assertRxUi
+#' @return TRUE if the model uses linear solved systems, FALSE otherwise
+#' @export
+#' @author Matthew L. Fidler
+#' @examples
+#'
+#' one.cmt <- function() {
+#'   ini({
+#'    ## You may label each parameter with a comment
+#'    tka <- 0.45 # Log 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)
+#'  })
+#'}
+#'
+#' testRxLinCmt(one.cmt)
+#'
+testRxLinCmt <- function(ui, extra="", .var.name=.vname(ui)) {
+  .ui <- assertRxUi(ui, extra=extra, .var.name=.var.name)
+  if (!is.null(.ui$.linCmtM)) {
+    return(TRUE)
+  }
+  .predDf <- .ui$predDf
+  if (any(.predDf$linCmt)) {
+    return(TRUE)
+  }
+  FALSE
+}
+
+#' @describeIn testRxLinCmt Assert that the rxode2 uses linear solved systems
+#' @export
+assertRxLinCmt <- function(ui, extra="", .var.name=.vname(ui)) {
+  .ui <- assertRxUi(ui, extra=extra, .var.name=.var.name)
+  if (testRxLinCmt(.ui)) {
+    return(invisible(.ui))
+  }
+  stop("'", .var.name, "' needs to have 'linCmt()'", extra, call.=FALSE)
+}
 
 #' @export
 #' @rdname assertRxUi

tests/testthat/test-assert.R

@@ -1,4 +1,46 @@
 if (!.Call(`_rxode2_isIntel`)) {
+  test_that("assert or testRxLinCmt", {
+    one.cmt <- function() {
+      ini({
+        tka <- 0.45; label("Ka")
+        tcl <- log(c(0, 2.7, 100)); label("Cl")
+        tv <- 3.45; label("V")
+        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)
+      })
+    }
+
+    expect_error(assertRxLinCmt(one.cmt), NA)
+    expect_true(testRxLinCmt(one.cmt))
+
+    mod <- function() {
+      ini({
+        cl <- 1.1
+        v <- 20
+        ka <- 1.5
+      })
+      model({
+        d/dt(depot) <- -ka*depot
+        d/dt(central) <- ka*depot - (cl/v)*central
+        f(central) <- bioav
+        if (mode == 1) rate(central) <- rat2
+        if (mode == 2) dur(central) <- dur2
+        cp <- central/(v/1000)
+      })
+    }
+
+    expect_error(assertRxLinCmt(mod))
+    expect_false(testRxLinCmt(mod))
+
+  })
   test_that("assertRxUiRandomOnIdOnly", {
     one.cmt <- function() {
       ini({