tests/testthat/test-sim-zeros.R

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

rxTest({
  test_that("simulate zeros tests", {
    
    # from nonmem2R
    f <- function() {
      description <- "PK"
      ini({
        t.CL <- c(0, 27.7322)
        label("1 CL L/h parent")
        t.V1 <- c(0, 112.773)
        label("2 V1 L parent")
        t.V2 <- c(0, 98.2478)
        label("3 V2 L parent")
        t.Q1 <- c(0, 20.8085)
        label("4 Q1 parent")
        theta5 <- c(0, 0.168248)
        label("5  ERROR parent")
        t.MTT <- c(0, 0.938162)
        label("6 MTT")
        F1 <- fix(1)
        label("7 F1")
        t.CLM <- c(0, 15.6045)
        label("8 CLM metabolite")
        t.VM1 <- c(0, 9.69614)
        label("9 VM1 L metabolite")
        t.VM2 <- c(0, 44.5183)
        label("10 VM2 L metabolite")
        t.Q2 <- c(0, 5.55961)
        label("11 Q2 metabolite")
        theta12 <- c(0, 0.145536)
        label("12 ERROR metabolite")
        theta13 <- c(0, 1.65686)
        label("13 Add ERROR parent")
        theta14 <- c(0, 1.07706)
        label("14 Add ERROR metabolite")
        NTR <- c(1, 1.95835, 12)
        label("15 NTR")
        eta1 ~ 0.0704585
        e.Q1 ~ 0.0386847
        eta3 ~ 0.0430261
        e.V2 ~ fix(0)
        e.KTR ~ 0.146879
        e.NTR ~ fix(0)
        Bioavailability ~ 0.0506769
      })
      model({
        cmt(cent)
        cmt(centmet)
        cmt(peri)
        cmt(perimet)
        if (newind <= 1) {
          tdos <- -1000
          pd <- 0
        }
        if (amt > 0) {
          tdos <- t
          pd <- amt
        }
        tad2 <- t - tdos
        e1 <- exp(eta1)
        e2 <- exp(e.Q1)
        e3 <- exp(eta3)
        e4 <- exp(e.V2)
        e5 <- exp(e.KTR)
        e6 <- exp(e.NTR)
        e7 <- exp(Bioavailability)
        tvcl <- t.CL
        cl <- tvcl * e1
        tvv1 <- t.V1
        v1 <- tvv1
        tvv2 <- t.V2
        v2 <- tvv2
        tvq1 <- t.Q1
        q1 <- tvq1 * e2
        tvclm <- t.CLM
        clm <- tvclm * e3
        tvvm1 <- t.VM1
        vm1 <- tvvm1
        tvvm2 <- t.VM2
        vm2 <- tvvm2 * e4
        tvq2 <- t.Q2
        q2 <- tvq2
        mtt <- t.MTT * e5
        nt <- 1 + NTR * e6
        ktr <- nt/mtt
        nn <- nt - 1
        if (nn >= 0.558) {
          l <- log(2.5066) + (nn + 0.5) * log(nn) - nn + log(1 + 
                                                               1/(12 * nn))
        } else {
          l <- -0.1171157 + 0.569 * ((0.558 - nn)^2) - 0.1122 * 
            (0.558 - nn)
        }
        k13 <- q1/v1
        k31 <- q1/v2
        TVFM <- 0.22
        fm <- TVFM
        k10 <- cl * (1 - fm)/v1
        k12 <- fm * cl/v1
        k24 <- q2/vm1
        k42 <- q2/vm2
        k20 <- clm/vm1
        scale1 <- v1
        scale2 <- vm1
        rxf.rxddta1. <- 0
        f(cent) <- rxf.rxddta1.
        bio <- F1 * e7
        X <- 1e-07
        if (t >= tdos) {
          d/dt(cent) <- bio * pd * ktr * exp(nn * log(ktr * 
                                                        (t - tdos) + X) - ktr * (t - tdos) - l) - k10 * 
                                         cent - k12 * cent - k13 * cent + k31 * peri
        } else {
          d/dt(cent) <- -k12 * cent - k13 * cent + k31 * peri
        }
        d/dt(centmet) <- k12 * cent - k20 * centmet - k24 * centmet + 
          k42 * perimet
        d/dt(peri) <- k13 * cent - k31 * peri
        d/dt(perimet) <- k24 * centmet - k42 * perimet
        f <- cent/scale1
        strt <- FLAG
        eps1 <- rxnorm()
        if (FLAG <= 1) {
          ipred <- cent/scale1
          w <- sqrt((theta5 * ipred)^2 + theta13^2)
          y <- ipred + w * eps1
        } else {
          ipred <- centmet/scale2
          w <- sqrt((theta12 * ipred)^2 + theta14^2)
          y <- ipred + w * eps1
        }
        cp <- cent/scale1
        cm <- centmet/scale2
        del <- 0
        if (w == 0) 
          del <- 1
        ires <- DV - ipred
        iwres <- ires/(w + del)
      })
    }
    f <- f()

    e <- et(amt=100) %>% et(seq(0,20))
    e$FLAG <- 1

    expect_error(rxSolve(f, e), NA)

    m <- f$simulationModel
    
    expect_error(rxSolve(m, params=f$theta, events=e, omega=f$omega), NA)

    # ok now try just the control

    .ctl <- rxControl(omega=lotri::lotri(eta1~c(0.0)))
    expect_equal(.ctl$omega, NULL)
    expect_equal(.ctl$.zeros, "eta1")

    .ctl <- rxControl(omega=lotri::lotri(eta1+eta2~c(0.0, 0.0, 1)))
    expect_equal(.ctl$omega, lotri::lotri(eta2~1.0))
    expect_equal(.ctl$.zeros, "eta1")

    .ctl <- rxControl(omega=lotri::lotri(eta1+eta2~c(0.0, 0.0, 1)),
                      omegaLower=c(-1, -1), omegaUpper=c(1,1))
    expect_equal(.ctl$omega, lotri::lotri(eta2~1.0))
    expect_equal(.ctl$.zeros, "eta1")
    expect_equal(.ctl$omegaLower, c(eta1=-1, eta2=-1))
    expect_equal(.ctl$omegaUpper, c(eta1=1, eta2=1))

    # sigma
    .ctl <- rxControl(sigma=lotri::lotri(eps1~c(0.0)))
    expect_equal(.ctl$sigma, NULL)
    expect_equal(.ctl$.zeros, "eps1")

    .ctl <- rxControl(sigma=lotri::lotri(eps1+eps2~c(0.0, 0.0, 1)))
    expect_equal(.ctl$sigma, lotri::lotri(eps2~1.0))
    expect_equal(.ctl$.zeros, "eps1")

    .ctl <- rxControl(sigma=lotri::lotri(eps1+eps2~c(0.0, 0.0, 1)),
                      sigmaLower=c(-1, -1), sigmaUpper=c(1,1))
    expect_equal(.ctl$sigma, lotri::lotri(eps2~1.0))
    expect_equal(.ctl$.zeros, "eps1")
    expect_equal(.ctl$sigmaLower, c(eps1=-1, eps2=-1))
    expect_equal(.ctl$sigmaUpper, c(eps1=1, eps2=1))
    
  })
})