tests/testthat/test-param_table.R

In ggPMX: 'ggplot2' Based Tool to Facilitate Diagnostic Plots for NLME Models

if (helper_skip()) {

  context("Test param_table() with theophylline controller")
  ctr <- theophylline()

  test_that("can make param_table()", {
    # Creating "pmxClass" controllers:
    ctr <- theophylline()

    nonmem_dir <- file.path(system.file(package = "ggPMX"), "testdata", "extdata")
    ctr_nm <- pmx_nm(directory = nonmem_dir, runno = "001")

    ctr_nm <- pmx_nm(
      directory = file.path(system.file(package = "ggPMX"), "testdata", "extdata"),
      runno = "001"
    )

    # Creating kable outputs for testing:
    p_ctr <- param_table(ctr, digits = 2, scientific = FALSE)
    p_ctr_nm <- param_table(ctr_nm, digits = 2, scientific = FALSE)
    p_ctr_sci <- param_table(ctr, digits = 2, scientific = TRUE)

    # Check headers
    expect_true(
      "|Parameter                                        |Value  |RSE   |Shrinkage |" %in% trimws(p_ctr)
    )

    expect_true(
      "|Parameter  |Value  |RSE    |Shrinkage     |" %in% trimws(p_ctr_nm)
    )

    # check a random row (here 5) of param_table
    expect_true(
      "|Cl                                               |0.31   |8%    |          |" %in% trimws(p_ctr),
      )

    expect_true(
      "|THETA1     |26     |3%     |              |" %in% trimws(p_ctr_nm),
      )

    # Check class:
    expect_s3_class(p_ctr, "knitr_kable")
    expect_s3_class(p_ctr_nm, "knitr_kable")

    # Check output lengths:
    expect_length(p_ctr, 23L)
    expect_length(p_ctr_nm, 23L)
    expect_length(p_ctr_sci, 23L)

    # Check scientific notation:
    p_ctr_sci <- param_table(ctr, digits = 2, scientific = TRUE)
    expect_true(any(grepl("\\de\\+\\d", p_ctr_sci)))
    expect_true(any(grepl("\\de\\-\\d", p_ctr_sci)))
  })

  test_that("param_table: params return: equal tables, identical names", {
    p_ctr <- ctr %>% param_table(return_table = TRUE)
    pop_pars <- ctr %>% get_data("estimates")
    Names <- c("PARAM", "VALUE", "SE", "RSE", "PVALUE")
    expect_equal(p_ctr, pop_pars)
    expect_identical(names(p_ctr), Names)
  })

  test_that("param_table: params return: identical sys in config", {
    p_t <- ctr %>% param_table(return_table = TRUE)
    expect_identical(ctr$config$sys, "mlx")
  })

  test_that("param_table: params: fun return: message `var` was used for shrinkage calculation", {
    p_t <- ctr %>% param_table(fun = "var")
    expect_message(ctr %>% param_table())
  })

  test_that("param_table: params NULL return:  identical inherits", {
    expect_s3_class(ctr %>% param_table, "knitr_kable")
  })

  #------------------- param_table with nlmixr start -----------------------------
  # context("Test param_table() with nlmixr controller")
  # if (requireNamespace("nlmixr2est", quietly=TRUE)) {
  #   test_that("param_table: params return: kable", {
  #     skip_on_os("windows")
  #     one.compartment <- function() {
  #       ini({
  #         tka <- 0.45 # Log Ka
  #         tcl <- 1 # Log Cl
  #         tv <- 3.45 # Log 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)
  #         d / dt(depot) <- -ka * depot
  #         d / dt(center) <- ka * depot - cl / v * center
  #         cp <- center / v
  #         cp ~ add(add.sd)
  #       })
  #     }
  #     fit <- nlmixr2est::nlmixr(one.compartment, nlmixr2data::theo_sd, "saem",
  #                            control = list(print = 0)
  #                            )
  #     ctr <- pmx_nlmixr(fit, conts = c("cl", "v"))
  #     expect_s3_class(param_table(ctr), "knitr_kable")
  #   })
  # }
  #------------------- param_table with nlmixr start -----------------------------
}