tests/testthat/test-udf.R

rxTest({

  udf <- function(x, y, ...) {
    x + y
  }

  expect_error(rxode2parse("b <- udf(x, y)"))

  udf <- function(x, y) {
    x + y
  }

  expect_error(rxode2parse("b <- udf(x, y)"), NA)

  expect_error(rxode2parse("b <- udf(x, y, z)"))

  rxode2parse("b <- udf(x, y)", code="udf.c")

  expect_true(file.exists("udf.c"))

  if (file.exists("udf.c")) {
    lines <- readLines("udf.c")
    unlink("udf.c")
    expect_false(file.exists("udf.c"))
  }

  .w <- which(grepl("b =_udf(\"udf\",", lines, fixed=TRUE))
  expect_true(length(.w) > 0)

  .w <- which(grepl("double __udf[2]", lines, fixed=TRUE))
  expect_true(length(.w) > 0)


  e <- et(1:10) |> as.data.frame()

  e$x <- 1:10
  e$y <- 21:30


  gg <- function(x, y) {
    x + y
  }

  f <- rxode2({
    z = gg(x, y)
  })


  test_that("udf1 works well", {
    expect_warning(rxSolve(f, e))

    d <- suppressWarnings(rxSolve(f, e))

    expect_true(all(d$z == d$x + d$y))
  })


  # now modify gg
  gg <- function(x, y, z) {
    x + y + z
  }

  test_that("udf with 3 arguments works", {
    expect_error(rxSolve(f, e))
  })

  # now modify gg back to 2 arguments
  gg <- function(x, y) {
    x * y
  }

  test_that("when changing gg the results will be different", {
    # different solve results but still runs

    d <- suppressWarnings(rxSolve(f, e))

    expect_true(all(d$z == d$x * d$y))

  })

  rm(gg)

  test_that("Without a udf, the solve errors", {
    expect_error(rxSolve(f, e))
  })


  gg <- function(x, ...) {
    x
  }

  test_that("cannot solve with udf functions that have ...", {
    expect_error(rxSolve(f, e))
  })

  gg <- function(x, y) {
    stop("running me")
  }

  test_that("functions that error will error the solve",{
    expect_error(rxSolve(f, e))
  })

  gg <- function(x, y) {
    "running "
  }


  test_that("runs with improper output will error", {
    expect_error(rxSolve(f, e))
  })

  gg <- function(x, y) {
    "3"
  }

  test_that("error for invalid input", {
    expect_error(rxSolve(f, e))
  })

  gg <- function(x, y) {
    3L
  }

  test_that("test symengine functions work with udf funs", {

    expect_equal(rxToSE("gg(x,y)"), "gg(x, y)")

    expect_error(rxToSE("gg()"), "user function")

    expect_error(rxFromSE("Derivative(gg(a,b),a)"), NA)

    expect_error(rxFromSE("Derivative(gg(a),a)"))

    expect_error(rxFromSE("Derivative(gg(),a)"))
  })

  gg <- function(x, ...) {
    x
  }

  test_that("test that functions with ... will error symengine translation", {
    expect_error(rxToSE("gg(x,y)"))

    expect_error(rxFromSE("Derivative(gg(a,b),a)"))
  })

  ## manual functions in C vs R functions

  gg <- function(x, y) {
    x + y
  }

  test_that("R vs C functions", {
    d <- suppressWarnings(rxSolve(f, e))
    expect_true(all(d$z == d$x + d$y))
  })

  # now add a C function with different values
  rxFun("gg", c("x", "y"),
        "double gg(double x, double y) { return x*y;}")


  test_that("C functions rule", {


    d <- suppressWarnings(rxSolve(f, e))

    expect_true(all(d$z == d$x * d$y))

  })

  rxRmFun("gg")

  test_that("c conversion", {

    udf <- function(x, y) {
      a <- x + y
      b <- a ^ 2
      a + b
    }

    expect_true(grepl("R_pow_di[(]", rxFun2c(udf)[[1]]$cCode))

    udf <- function(x, y) {
      a <- x + y
      b <- a ^ x
      a + b
    }

    expect_true(grepl("R_pow[(]", rxFun2c(udf)[[1]]$cCode))

    udf <- function(x, y) {
      a <- x + y
      b <- cos(a) + x
      a + b
    }

    expect_true(grepl("cos[(]", rxFun2c(udf)[[1]]$cCode))

    udf <- function(x, y) {
      if (a < b) {
        return(b ^ 2)
      }
      a + b
    }

    expect_true(grepl("if [(]", rxFun2c(udf)[[1]]$cCode))


    udf <- function(x, y) {
      a <- x
      b <- x ^ 2 + a
      if (a < b) {
        return(b ^ 2)
      } else {
        a + b
      }
    }

    expect_true(grepl("else [{]", rxFun2c(udf)[[1]]$cCode))

    udf <- function(x, y) {
      a <- x
      b <- x ^ 2 + a
      if (a < b) {
        return(b ^ 2)
      } else if (a > b + 3) {
        return(a + b)
      }
      a ^ 2 + b ^ 2
    }

    expect_true(grepl("else if [(]", rxFun2c(udf)[[1]]$cCode))

    udf <- function(x, y) {
      a <- x
      b <- x ^ 2 + a
      if (a < b) {
        return(b ^ 2)
      } else if (a > b + 3) {
        b <- 3
        if (a > 2) {
          a <- 2
        }
        return(a + b)
      }
      a ^ 2 + b ^ 2
    }

    expect_true(grepl("else if [(]", rxFun2c(udf)[[1]]$cCode))

    udf <- function(x, y) {
      a <- x + y
      x <- a ^ 2
      x
    }

    expect_error(rxFun2c(udf)[[1]]$cCode)


    udf <- function(x, y) {
      a <- x
      b <- x ^ 2 + a
      if (a < b) {
        b ^ 2
      } else {
        a + b
      }
    }

    rxFun(udf)
    rxRmFun("udf")

  })

  test_that("udf with model functions", {

    gg <- function(x, y) {
      x/y
    }

    # Step 1 - Create a model specification
    f <- function() {
      ini({
        KA <- .291
        CL <- 18.6
        V2 <- 40.2
        Q <- 10.5
        V3 <- 297.0
        Kin <- 1.0
        Kout <- 1.0
        EC50 <- 200.0
      })
      model({
        # A 4-compartment model, 3 PK and a PD (effect) compartment
        # (notice state variable names 'depot', 'centr', 'peri', 'eff')
        C2 <- gg(centr, V2)
        C3 <- peri/V3
        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
        eff(0) <- 1
      })
    }

    u <- f()

    # this pre-compiles and displays the simulation model
    u$simulationModel

    # Step 2 - Create the model input as an EventTable,
    # including dosing and observation (sampling) events

    # QD (once daily) dosing for 5 days.

    qd <- eventTable(amount.units = "ug", time.units = "hours")
    qd$add.dosing(dose = 10000, nbr.doses = 5, dosing.interval = 24)

    # Sample the system hourly during the first day, every 8 hours
    # then after

    qd$add.sampling(0:24)
    qd$add.sampling(seq(from = 24 + 8, to = 5 * 24, by = 8))

    # Step 3 - set starting parameter estimates and initial
    # values of the state

    # Step 4 - Fit the model to the data
    expect_error(suppressWarnings(solve(u, qd)), NA)

    u1 <- u$simulationModel

    expect_error(suppressWarnings(solve(u1, qd)), NA)

    u2 <- u$simulationIniModel
    expect_error(suppressWarnings(solve(u2, qd)), NA)

    expect_error(suppressWarnings(rxSolve(f, qd)), NA)
  })

  test_that("symengine load", {

    mod <- "tke=THETA[1];\nprop.sd=THETA[2];\neta.ke=ETA[1];\nke=gg(tke,exp(eta.ke));\nipre=gg(10,exp(-ke*t));\nlipre=log(ipre);\nrx_yj_~2;\nrx_lambda_~1;\nrx_low_~0;\nrx_hi_~1;\nrx_pred_f_~ipre;\nrx_pred_~rx_pred_f_;\nrx_r_~(rx_pred_f_*prop.sd)^2;\n"

    gg <- function(x, y) {
      x * y
    }

    expect_error(rxS(mod, TRUE, TRUE), NA)

    rxFun(gg)

    rm(gg)

    expect_error(rxS(mod, TRUE, TRUE), NA)

    rxRmFun("gg")


  })

})


test_that("udf type 2 (that changes ui models upon parsing)", {

  expect_error(rxModelVars("a <- linMod(x, 3)"), NA)
  expect_error(rxModelVars("a <- linMod(x, 3, b)"))
  expect_error(rxModelVars("a <- linMod(x)"))
  expect_error(rxModelVars("a <- linMod()"))

  f <- rxode2({
    a <- linMod(x, 3)
  })

  e <- et(1:10)

  expect_error(rxSolve(f, e, c(x=2)), "ui user function")

  # Test a linear model construction

  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linMod(time, 3)
      b <-  d
    })
  }

  tmp <- f()

  expect_equal(tmp$iniDf$name,
               c("d", "rx.linMod.time1a", "rx.linMod.time1b", "rx.linMod.time1c",
                 "rx.linMod.time1d"))

  expect_equal(modelExtract(tmp, a),
               "a <- (rx.linMod.time1a + rx.linMod.time1b * time + rx.linMod.time1c * time^2 + rx.linMod.time1d * time^3)")

  # Test a linear model construction without an intercept
  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linMod0(time, 3) + d
    })
  }

  tmp <- f()

  expect_equal(tmp$iniDf$name,
               c("d", "rx.linMod.time1a", "rx.linMod.time1b", "rx.linMod.time1c"))


  expect_equal(modelExtract(tmp, a),
               "a <- (rx.linMod.time1a * time + rx.linMod.time1b * time^2 + rx.linMod.time1c * time^3) + d")

  # Now test the use of 2 linear models in the UI
  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linMod(time, 3)
      b <- linMod(time, 3)
      c <- d
    })
  }

  tmp <- f()

  expect_equal(tmp$iniDf$name,
               c("d", "rx.linMod.time1a", "rx.linMod.time1b", "rx.linMod.time1c", "rx.linMod.time1d",
                 "rx.linMod.time2a", "rx.linMod.time2b", "rx.linMod.time2c", "rx.linMod.time2d"))

  expect_equal(modelExtract(tmp, a),
               "a <- (rx.linMod.time1a + rx.linMod.time1b * time + rx.linMod.time1c * time^2 + rx.linMod.time1d * time^3)")

  expect_equal(modelExtract(tmp, b),
               "b <- (rx.linMod.time2a + rx.linMod.time2b * time + rx.linMod.time2c * time^2 + rx.linMod.time2d * time^3)")


  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linModB(time, 3)
      b <-  d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, rx.linMod.time.f1),
               "rx.linMod.time.f1 <- rx.linMod.time1a + rx.linMod.time1b * time + rx.linMod.time1c * time^2 + rx.linMod.time1d * time^3")

  expect_equal(modelExtract(tmp, a),
               "a <- rx.linMod.time.f1")

  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linModB0(time, 3) + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, rx.linMod.time.f1),
               "rx.linMod.time.f1 <- rx.linMod.time1a * time + rx.linMod.time1b * time^2 + rx.linMod.time1c * time^3")

  expect_equal(modelExtract(tmp, a),
               "a <- rx.linMod.time.f1 + d")

  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linModA(time, 1) + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, rx.linMod.time.f1),
               "rx.linMod.time.f1 <- rx.linMod.time1a + rx.linMod.time1b * time")

  expect_equal(modelExtract(tmp, a),
               "a <- 0 + d")

  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linModA0(time, 1) + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, rx.linMod.time.f1),
               "rx.linMod.time.f1 <- rx.linMod.time1a * time")

  expect_equal(modelExtract(tmp, a),
               "a <- 0 + d")

  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linMod(power=3, variable="x") + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, a),
               "a <- (rx.linMod.x1a + rx.linMod.x1b * x + rx.linMod.x1c * x^2 + rx.linMod.x1d * x^3) + d")

  expect_false(tmp$uiUseData)


  ## Formula interface
  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linMod0(dv~x^3) + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, a),
               "a <- linModD0(x, 3, dv) + d")
  expect_true(tmp$uiUseData)

  ## Formula interface
  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linMod0(~x^3) + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, a),
               "a <- (rx.linMod.x1a * x + rx.linMod.x1b * x^2 + rx.linMod.x1c * x^3) + d")

  ## Formula interface
  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linMod0(~x^6) + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, a),
               "a <- (rx.linMod.x1a * x + rx.linMod.x1b * x^2 + rx.linMod.x1c * x^3 + rx.linMod.x1d * x^4 + rx.linMod.x1e * x^5 + rx.linMod.x1f * x^6) + d")


  # This checks to make sure that the variables are not in the model
  # before adding them
  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linModM0(~x^6) + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, a),
               "a <- (x1a * x + x1b * x^2 + x1c * x^3 + x1d * x^4 + x1e * x^5 + x1f * x^6) + d")


  f <- function() {
    ini({
      d <- 4
    })
    model({
      a <- linModM(~x^6) + d
    })
  }

  tmp <- f()

  expect_equal(modelExtract(tmp, a),
               "a <- (x1a + x1b * x + x1c * x^2 + x1d * x^3 + x1e * x^4 + x1f * x^5 + x1g * x^6) + d")

  rxWithSeed(42, {

    q <- seq(from=0, to=20, by=0.1)

    y <- 500 + 42*q^2 + 0.4 * (q-10)^3

    df <- data.frame(q=q, y=y)

    f <- function() {
      model({
        a <- linMod(y~q^3)
      })
    }

    f <- f()

    expect_equal(modelExtract(f, a),
                 "a <- linModD(q, 3, y)")

    rxUdfUiData(df)

    try({
      if (f$uiUseData) {
        f <- rxode2(as.function(f))
        expect_false(any(f$theta == 0))
      }
    })
    rxUdfUiData(NULL)
  })




})
nlmixr2/rxode2 documentation built on Jan. 11, 2025, 8:48 a.m.