tests/testthat/test-ui-assign-model-parts.R

In nlmixr2/rxode2: Facilities for Simulating from ODE-Based Models

if (!.Call(`_rxode2_isIntel`)) {
  test_that("rxode2<- and other rxUi methods", {

    one.compartment <- function() {
      ini({
        tka <- log(1.57)
        tcl <- log(2.72)
        tv <- log(31.5)
        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)
        d/dt(depot) = -ka * depot
        d/dt(center) = ka * depot - cl / v * center
        cp = center / v
        cp ~ add(add.sd)
      })
    }

    one.compartment2 <- function() {
      ini({
        tka <- 1.57
        tcl <- 2.72
        tv <- 31.5
        eta.ka ~ 0.6
        eta.cl ~ 0.3
        eta.v ~ 0.1
        add.sd <- 0.7
      })
      model({
        ka <- tka * exp(eta.ka)
        cl <- tcl *exp(eta.cl)
        v <- tv*exp(eta.v)
        d/dt(depot) = -ka * depot
        d/dt(center) = ka * depot - cl / v * center
        cp = center / v
        cp ~ add(add.sd)
      })
    }

    two.compartment <- function() {
      ini({
        lka <- 0.45
        lcl <- 1
        lvc  <- 3
        lvp  <- 5
        lq  <- 0.1
        propSd <- 0.5
      })
      model({
        ka <- exp(lka)
        cl <- exp(lcl)
        vc <- exp(lvc)
        vp <- exp(lvp)
        q  <- exp(lq)
        kel <- cl/vc
        k12 <- q/vc
        k21 <- q/vp
        d/dt(depot) <- -ka*depot
        d/dt(central) <-  ka*depot - kel*central - k12*central + k21*peripheral1
        d/dt(peripheral1) <- k12*central - k21*peripheral1
        cp <- central / vc
        cp ~ prop(propSd)
      })
    }

    uiOne <- rxode2(one.compartment)
    uiTwo <- uiOne
    rxode2(uiTwo) <- body(two.compartment)
    expect_equal(body(uiOne$fun), body(rxode2(one.compartment)$fun))
    expect_equal(body(uiTwo$fun), body(rxode2(two.compartment)$fun))

    fun1 <- one.compartment
    fun2 <- two.compartment
    rxode2(fun1) <- fun2
    expect_equal(fun1, fun2)

    fun1 <- one.compartment
    rxode2(fun1) <- body(fun2)
    expect_equal(deparse1(fun1), deparse1(fun2))

    expect_error({
      rxode2(fun1) <- "matt"
    })

    uiOne <- rxode2(one.compartment)
    uiTwo <- uiOne
    rxode2(uiTwo) <- two.compartment

    expect_equal(body(uiOne$fun), body(rxode2(one.compartment)$fun))
    expect_equal(body(uiTwo$fun), body(rxode2(two.compartment)$fun))

    uiOne <- rxode2(one.compartment)
    uiOne$model <- model(one.compartment2)
    expect_equal(model(uiOne), model(one.compartment2))
    expect_equal(ini(uiOne), ini(one.compartment))


    uiOne <- rxode2(one.compartment)

    model(uiOne) <-  model(one.compartment2)
    expect_equal(model(uiOne), model(one.compartment2))
    expect_equal(ini(uiOne), ini(one.compartment))

    uiOne <- rxode2(one.compartment)
    ini(uiOne) <-  ini(one.compartment2)
    expect_equal(model(uiOne), model(one.compartment))
    expect_equal(ini(uiOne), ini(one.compartment2))

    # now lets add something to the model that should be kept and dropped
    uiOne <- rxUiDecompress(rxode2(one.compartment))
    uiOne$sticky <- "matt"
    uiOne$matt <- "f"
    uiOne$f <- "matt"
    class(uiOne) <- c("uiOne", class(uiOne))

    # this makes "insignificant" changes
    iniNew <- quote(ini({
      tka <- c(-Inf, 0.451075619360217, 2.99573227355399)
      tcl <- fix(1.00063188030791)
      tv <- 3.44998754583159
      label("tv")
      add.sd <- c(0, 0.7)
      eta.ka ~ 0.6
      eta.cl ~ 0.3
      eta.v ~ 0.1
    }))

    ini(uiOne) <-  iniNew
    expect_equal(ini(uiOne), iniNew)
    expect_equal(uiOne$matt, "f")
    expect_equal(uiOne$f, "matt")
    expect_true(inherits(uiOne, "uiOne"))

    # order is also an insignificant change
    iniNew <- quote(ini({
      tcl <- fix(1.00063188030791)
      tka <- c(-Inf, 0.451075619360217, 2.99573227355399)
      tv <- 3.44998754583159
      label("tv")
      add.sd <- c(0, 0.7)
      eta.ka ~ 0.6
      eta.v ~ 0.1
      eta.cl ~ 0.3
    }))

    ini(uiOne) <-  iniNew

    expect_equal(ini(uiOne), iniNew)
    expect_equal(uiOne$matt, "f")
    expect_equal(uiOne$f, "matt")
    expect_true(inherits(uiOne, "uiOne"))

    ## changing an estimate is a significant change
    iniNew <- quote(ini({
      tka <- c(-Inf, 0.451075619360217, 2.99573227355399)
      tcl <- fix(1.00063188030791)
      tv <- 3.44998754583159
      label("tv")
      add.sd <- c(0, 0.7)
      eta.ka ~ 0.6
      eta.cl ~ 0.3
      eta.v ~ 1
    }))

    ini(uiOne) <-  iniNew

    expect_equal(ini(uiOne), iniNew)
    expect_equal(uiOne$matt, "f")
    expect_equal(uiOne$f, NULL)
    expect_true(inherits(uiOne, "uiOne"))

    # now test changing model() should be a significant change
    uiOne <- rxUiDecompress(rxode2(one.compartment))
    uiOne$sticky <- "matt"
    uiOne$matt <- "f"
    uiOne$f <- "matt"
    class(uiOne) <- c("uiOne", class(uiOne))

    model(uiOne) <-  model(one.compartment2)

    expect_equal(model(uiOne), model(one.compartment2))
    expect_equal(uiOne$matt, "f")
    expect_equal(uiOne$f, NULL)
    expect_true(inherits(uiOne, "uiOne"))

    # now test piping
    uiOne <- rxUiDecompress(rxode2(one.compartment))
    uiOne$sticky <- "matt"
    uiOne$matt <- "f"
    uiOne$f <- "matt"
    class(uiOne) <- c("uiOne", class(uiOne))

    uiTwo <- uiOne %>%
      ini(tka=fix)

    expect_equal(uiTwo$matt, "f")
    expect_equal(uiTwo$f, "matt")
    expect_true(inherits(uiTwo, "uiOne"))

    # now a significant change
    uiTwo <- uiOne %>%
      ini(tcl=77)

    expect_equal(uiTwo$matt, "f")
    expect_equal(uiTwo$f, NULL)
    expect_true(inherits(uiTwo, "uiOne"))

    # nothing change in input ui
    expect_equal(uiOne$matt, "f")
    expect_equal(uiOne$f, "matt")
    expect_true(inherits(uiOne, "uiOne"))

    uiTwo <- uiOne %>%
      model(ka <- tka * exp(eta.ka))

    expect_equal(uiTwo$matt, "f")
    expect_equal(uiTwo$f, NULL)
    expect_true(inherits(uiTwo, "uiOne"))

    # rename something in the model block, insignificant
    uiTwo <- uiOne %>%
      rxRename(isKa=ka)

    expect_equal(uiTwo$matt, "f")
    expect_equal(uiTwo$f, "matt")
    expect_true(inherits(uiTwo, "uiOne"))


    # rename something in the ini block is also an insignificant change
    uiTwo <- uiOne %>%
      rxRename(isKa=tka)

    expect_equal(uiTwo$matt, "f")
    expect_equal(uiTwo$f, "matt")
    expect_true(inherits(uiTwo, "uiOne"))



  })

  test_that("ini(model) <- NULL drops", {
    one.compartment <- function() {
      ini({
        tka <- log(1.57)
        tcl <- log(2.72)
        tv <- log(31.5)
        eta.ka ~ 0.6
        eta.cl ~ 0.3
        eta.v ~ 0.1
      })
      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
      })
    }

    uiOne <- one.compartment()
    ini(uiOne) <- NULL
    expect_length(uiOne$iniDf$ntheta, 0L)
    expect_equal(as.ini(NULL), quote(ini({}))) #nolint

    # try with $ini assignment
    uiOne <- one.compartment()
    uiOne$ini <- NULL
    expect_length(uiOne$iniDf$ntheta, 0L)
    expect_equal(as.ini(NULL), quote(ini({}))) #nolint
  })

  test_that("assign model changes meta information", {

    one.compartment <- function() {
      ini({
        tka <- log(1.57)
        tcl <- log(2.72)
        tv <- log(31.5)
        eta.ka ~ 0.6
        eta.cl ~ 0.3
        eta.v ~ 0.1
      })
      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
      })
    }

    uiOne <- one.compartment()

    uiOne$matt <- "matt"

    expect_equal(uiOne$meta$matt, "matt")

    expect_equal(uiOne$matt, "matt")

  })
}