tests/testthat/test-occ.R

rxTest({
  test_that("occasions", {

    # Nesting tests

    mod <- rxode2({
      eff(0) <- 1
      C2 <- centr / V2 * (1 + prop.err)
      C3 <- peri / V3
      CL <- TCl * exp(eta.Cl + iov.Cl)
      KA <- TKA * exp(eta.Ka + iov.Ka)
      d/dt(depot) <- -KA * depot
      d/dt(centr) <- KA * depot - CL * C2 - Q * C2 + Q * C3
      d/dt(peri) <- Q * C2 - Q * C3
      d/dt(eff) <- Kin - Kout * (1 - C2 / (EC50 + C2)) * eff
    })

    mod.eta <- rxode2({
      eff(0) <- 1
      C2 <- centr / V2 * (1 + prop.err)
      C3 <- peri / V3
      CL <- TCl * exp(ETA[1] + iov.Cl)
      KA <- TKA * exp(ETA[2] + iov.Ka)
      d / dt(depot) <- -KA * depot
      d / dt(centr) <- KA * depot - CL * C2 - Q * C2 + Q * C3
      d / dt(peri) <- Q * C2 - Q * C3
      d / dt(eff) <- Kin - Kout * (1 - C2 / (EC50 + C2)) * eff
    })

    et(amountUnits = "mg", timeUnits = "hours") %>%
      et(amt = 10000, addl = 9, ii = 12, cmt = "depot") %>%
      et(time = 120, amt = 2000, addl = 4, ii = 14, cmt = "depot") %>%
      et(seq(0, 240, by = 4)) %>%
      # Assumes sampling when there is no dosing information
      et(seq(0, 240, by = 4) + 0.1) %>%
      ## adds 0.1 for separate eye
      et(id = 1:20) %>%
      ## Add an occasion per dose
      dplyr::mutate(occ = cumsum(!is.na(amt))) %>%
      dplyr::mutate(occ = ifelse(occ == 0, 1, occ)) %>%
      dplyr::mutate(occ = 2 - occ %% 2) %>%
      dplyr::mutate(eye = ifelse(round(time) == time, 1, 2)) %>%
      dplyr::mutate(inv = ifelse(id < 10, 1, 2)) ->
      ev

      omega <- lotri(
        lotri(
          eta.Cl ~ 0.1,
          eta.Ka ~ 0.1
        ) | id(nu = 100),
        lotri(
          eye.Cl ~ 0.05,
          eye.Ka ~ 0.05
        ) | eye(nu = 50, same = 2),
        lotri(
          iov.Cl ~ 0.01,
          iov.Ka ~ 0.01
        ) | occ(nu = 200, same = 2),
        lotri(
          inv.Cl ~ 0.02,
          inv.Ka ~ 0.02
        ) | inv(nu = 10, same = 2)
      )
      attr(omega, "format") <- "THETA[%d]"
      attr(omega, "start") <- 2L

      ## cvPost(nu=1000, omega, 2)

      omega <- lotri(
        lotri(
          eta.Cl ~ 0.1,
          eta.Ka ~ 0.1
        ) | id(nu = 100),
        lotri(
          eye.Cl ~ 0.05,
          eye.Ka ~ 0.05
        ) | eye(nu = 50),
        lotri(
          iov.Cl ~ 0.01,
          iov.Ka ~ 0.01
        ) | occ(nu = 200),
        lotri(
          inv.Cl ~ 0.02,
          inv.Ka ~ 0.02
        ) | inv(nu = 10)
      )

      .ni <- nestingInfo_(omega, ev)

      expect_equal(.ni$below, c(eye = 2L, occ = 2L))
      expect_equal(.ni$above, c(inv = 2L))
      expect_s3_class(.ni$data$eye, "factor")
      expect_equal(attr(.ni$data$eye, "nu"), 40L)
      expect_s3_class(.ni$data$inv, "factor")
      expect_equal(attr(.ni$data$inv, "nu"), NULL)
      expect_s3_class(.ni$data$occ, "factor")
      expect_equal(attr(.ni$data$occ, "nu"), 40L)

      expect_equal(.ni$extraTheta, 4)
      expect_equal(.ni$extraEta, 8)

      .en <- rxExpandNesting(mod, .ni, compile = TRUE)

      .ett <- etTrans(.ni$data, .en$mod)

      theta <- c(
        KA = 2.94E-01, CL = 1.86E+01, V2 = 4.02E+01, # central
        Q = 1.05E+01, V3 = 2.97E+02, # peripheral
        Kin = 1, Kout = 1, EC50 = 200
      ) # effects

      thetaMat <- lotri(
        KA ~ 0.01,
        CL ~ 0.01,
        V2 ~ 0.01,
        Q ~ 0.01,
        V3 ~ 0.01,
        Kin ~ 0.01,
        Kout ~ 0.01,
        EC50 ~ 0.01
      )

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               thetaMat = thetaMat, omega = omega,
                               nSub = 40, nStud = 3))

      expect_equal(length(.ep$KA), 120L)
      expect_equal(length(unique(.ep$KA)), 3L)

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               thetaMat = thetaMat, omega = omega,
                               nStud = 3
                             )
                             )

      expect_equal(length(.rxModels[[".thetaL"]]), 3L)
      expect_equal(length(.rxModels[[".omegaL"]]), 3L)
      expect_equal(.rxModels[[".sigmaL"]], NULL)
      expect_equal(length(.ep$KA), 60L)
      expect_equal(length(unique(.ep$KA)), 3L)
      expect_true(any(names(.ep) == "eta.Cl"))

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               thetaMat = thetaMat, omega = omega,
                               nStud = 3, nSub = 20
                             )
                             )

      expect_equal(length(.rxModels[[".thetaL"]]), 3L)
      expect_equal(length(.rxModels[[".omegaL"]]), 3L)
      expect_equal(.rxModels[[".sigmaL"]], NULL)
      expect_equal(length(.ep$KA), 60L)
      expect_true(any(names(.ep) == "eta.Cl"))

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               thetaMat = thetaMat, omega = omega,
                               sigma = lotri(prop.err ~ 0.1), dfObs = 10,
                               nStud = 3, nSub = 20
                             )
                             )

      expect_equal(length(.rxModels[[".thetaL"]]), 3L)
      expect_equal(length(.rxModels[[".omegaL"]]), 3L)
      expect_equal(length(.rxModels[[".sigmaL"]]), 3L)
      expect_equal(length(.ep$KA), 60L)
      expect_true(any(names(.ep) == "eta.Cl"))

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               thetaMat = thetaMat,
                               sigma = lotri(prop.err ~ 0.1), dfObs = 10,
                               nStud = 3, nSub = 20
                             )
                             )

      expect_equal(.rxModels[[".thetaL"]], NULL)
      expect_equal(.rxModels[[".omegaL"]], NULL)
      expect_equal(length(.rxModels[[".sigmaL"]]), 3L)
      expect_equal(length(.ep$KA), 60L)
      expect_false(any(names(.ep) == "eta.Cl"))


      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               sigma = lotri(prop.err ~ 0.1), dfObs = 10,
                               nStud = 3, nSub = 20
                             )
                             )

      expect_equal(.rxModels[[".thetaL"]], NULL)
      expect_equal(.rxModels[[".omegaL"]], NULL)
      expect_equal(length(.rxModels[[".sigmaL"]]), 3L)
      expect_equal(length(.ep$KA), 60L)
      expect_false(any(names(.ep) == "eta.Cl"))

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               sigma = lotri(prop.err ~ 0.1), dfObs = 10,
                               nStud = 3, nSub = 20
                             )
                             )

      expect_equal(.rxModels[[".thetaL"]], NULL)
      expect_equal(.rxModels[[".omegaL"]], NULL)
      expect_equal(length(.rxModels[[".sigmaL"]]), 3L)
      expect_equal(length(.ep$KA), 60L)
      expect_false(any(names(.ep) == "eta.Cl"))

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               omega = lotri(eta.Cl ~ 0.1), dfObs = 10,
                               nStud = 3, nSub = 20
                             )
                             )

      expect_equal(.rxModels[[".thetaL"]], NULL)
      expect_equal(.rxModels[[".omegaL"]], NULL)
      expect_equal(.rxModels[[".sigmaL"]], NULL)
      expect_equal(length(.ep$KA), 60L)
      expect_true(any(names(.ep) == "eta.Cl"))

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(dfObs = 10, nStud = 3, nSub = 4)
                             )

      expect_equal(.rxModels[[".thetaL"]], NULL)
      expect_equal(.rxModels[[".omegaL"]], NULL)
      expect_equal(.rxModels[[".sigmaL"]], NULL)
      expect_equal(length(.ep$KA), 12L)
      expect_false(any(names(.ep) == "eta.Cl"))


      expect_error(.expandPars(mod, NULL, ev,
                                   control = rxControl(thetaMat = thetaMat, omega = omega, nStud = 3)
                                   ))

      .ep <- .expandPars(mod, NULL, ev,
                             control = rxControl(omega = omega, nStud = 3)
                             )

      expect_equal(length(.rxModels[[".thetaL"]]), 3L)
      expect_equal(length(.rxModels[[".omegaL"]]), 3L)
      expect_equal(.rxModels[[".sigmaL"]], NULL)
      expect_equal(length(.ep$eta.Ka), 60L)
      expect_true(any(names(.ep) == "eta.Cl"))

      .ep <- .expandPars(mod, NULL, ev,
                             control = rxControl(
                               omega = omega,
                               nStud = 3, dfObs = 100, nSub = 20, dfSub = 10
                             )
                             )

      expect_equal(length(.rxModels[[".thetaL"]]), 3L)
      expect_equal(length(.rxModels[[".omegaL"]]), 3L)
      expect_equal(.rxModels[[".sigmaL"]], NULL)
      expect_equal(length(.ep$eta.Ka), 60L)
      expect_true(any(names(.ep) == "eta.Cl"))

      .ep <- .expandPars(mod, theta, ev,
                             control = rxControl(
                               thetaMat = lotri(KA ~ 1, CL ~ 1),
                               omega = omega,
                               sigma = lotri(prop.err ~ 0.1), dfObs = 10,
                               nStud = 3, nSub = 20
                             )
                             )

      ## Test edge case -- no between or above occasion variability

      .ni <- nestingInfo_(
        lotri(lotri(eta.Cl ~ 0.1, eta.Ka ~ 0.1) | id(nu = 100)),
        ev
      )

      expect_equal(.ni$above, structure(integer(0), .Names = character(0)))
      expect_equal(.ni$below, structure(integer(0), .Names = character(0)))
      expect_equal(.ni$idName, "id")
      expect_s3_class(.ni$omega, "lotri")
      expect_equal(names(.ni$omega), "id")

      .en <- rxExpandNesting(mod, .ni)
  })

  test_that("nesting test from https://github.com/nlmixr2/rxode2random/issues/25", {

    mod <- rxode2({
      TABS = TV_TABS * exp(eta.TABS + iov.TABS)
      TR_Fbio = TV_TR_Fbio + eta.TR_Fbio + iov.TR_Fbio
      CL = TV_CL * exp(eta.CL)
      V1 = TV_V1 * exp(eta.V1)
      V2 = TV_V2 * exp(eta.V2)
      CLD = TV_CLD * exp(eta.CLD)
      KA = log(2) / (TABS/60)
      FBIO = 1 / (exp(-TR_Fbio) + 1)
      DC1 = AMT1/V1
      DC2 = AMT2/V2
      d/dt(AMTa) =       -KA * AMTa
      d/dt(AMT1) = FBIO * KA * AMTa - CLD * DC1 + CLD * DC2 - CL * DC1
      d/dt(AMT2) =                  + CLD * DC1 - CLD * DC2
      d/dt(AUC) = DC1
    })

    n <- 10

    theta <- c("TV_TABS" = 45,
              "TV_TR_Fbio" = logit(x = 0.85),
              "TV_CL" = 10,
              "TV_V1" = 10,
              "TV_V2" = 65,
              "TV_CLD" = 25)


    omega <- lotri::lotri(
      lotri::lotri(eta.TABS~0.25,
                   eta.TR_Fbio~0.20,
                   eta.CL~0.30,
                   eta.V1~0.30,
                   eta.V2~0.45,
                   eta.CLD~0.15) | id(nu=n),
      lotri::lotri(iov.TABS~0.15,
                   iov.TR_Fbio~0.15) | occ(nu=n*2))

    dosing <- et(amt=1000,
                addl=6,
                ii=24,
                evid=1,
                cmt="AMTa",
                time=0) %>%
      et(amt=1000,
         addl=6,
         ii=24,
         evid=4,
         cmt="AMTa",
         time = 336) %>%
      et(seq(0,168,0.5)) %>%
      et(seq(336,672,0.5)) %>%
      et(id=seq(1,n))

    dosing <- dplyr::mutate(dosing, occ = 1) %>%
      dplyr::mutate(occ = ifelse(time>=336,2,occ))

    expect_error(rxSolve(object = mod,
                             theta,
                             omega=omega,
                             ev=dosing,
                             nDisplayProgress=100L), NA)
  })
})
nlmixr2/rxode2 documentation built on Jan. 11, 2025, 8:48 a.m.