tests/testthat/test-plot.R

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

if (helper_skip()) {

  context("Test filtering of controller data")
  pmxClassHelpers <- test_pmxClass_helpers()

  test_that("individual plot: get all pages", {
    ctr <- pmxClassHelpers$ctr
    expect_is(ctr, "pmxClass")
    p <- ctr %>% get_plot("individual")
    expect_equal(length(p), 5)
  })


  test_that("individual plot: get single page", {
    ctr <- pmxClassHelpers$ctr
    expect_is(ctr, "pmxClass")
    p <- ctr %>% get_plot("individual", 2)
    expect_true(inherits(p, "ggplot"))
  })


  test_that("smooth_with_bloq result: smoothing with/wo BLOQ data", {
    ctr <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0"))
    p1 <- pmx_plot_abs_iwres_ipred(ctr, smooth_with_bloq=FALSE)
    p2 <- pmx_plot_abs_iwres_ipred(ctr, smooth_with_bloq=TRUE)
    p3 <- pmx_plot_abs_iwres_ipred(ctr)
    p1_obj <- ggplot2::ggplot_build(p1)
    p2_obj <- ggplot2::ggplot_build(p2)
    p3_obj <- ggplot2::ggplot_build(p3)

    expect_false(identical(p1_obj[["data"]][[4]], p2_obj[["data"]][[4]]))
    expect_identical(p1_obj[["data"]][[4]], p3_obj[["data"]][[4]])
  })

  test_that("individual plot: get some pages", {
    ctr <- pmxClassHelpers$ctr
    expect_is(ctr, "pmxClass")
    p <- ctr %>% get_plot("individual", c(2, 4))
    expect_equal(length(p), 2)
  })


  test_that("individual plot : don't exceed the effective number of pages", {
    ctr <- pmxClassHelpers$ctr
    expect_is(ctr, "pmxClass")
    p <- ctr %>% get_plot("individual", 1:100)
    expect_equal(length(p), 5)
  })


  test_that("bloq data has separate colour", {
    ctr <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0"))

    plots_with_bloq <- c("individual", "abs_iwres_ipred", "abs_iwres_time",
                         "iwres_ipred", "iwres_time", "npde_time", "npde_pred", "dv_pred", "dv_ipred")

    lapply(
      paste0("pmx_plot_", plots_with_bloq),
      function(x) {expect_equal("pink", get(x)(ctr)[["plot_env"]][["bloq"]][["colour"]])}
    )
  })


  test_that("can create a plot using setting dname", {
    ctr <- pmxClassHelpers$ctr
    expect_is(ctr, "pmxClass")
    ctr %>% set_plot("DIS", pname = "distr1", type = "box", dname = "eta")
    p <- ctr %>% get_plot("distr1")
    pconf <- ggplot2::ggplot_build(p)
    expect_equal(length(pconf$plot$layers), 5)
  })


  test_that("controller bloq parameters are applied to the plots", {
    ctr_no_bloq <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0", show=FALSE))
    ctr_show_bloq <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0", show=TRUE))

    plots_with_bloq <- c("individual", "abs_iwres_ipred", "abs_iwres_time",
                         "iwres_ipred", "iwres_time", "npde_time", "npde_pred", "dv_pred", "dv_ipred")

    getFunBloq <- function(s, ctr) {
      get(paste0("pmx_plot_", s))(ctr)[["plot_env"]][["bloq"]]
    }

    lapply(plots_with_bloq, function(s) {
      expect_null(getFunBloq(s, ctr_no_bloq))
      expect_false(is.null(getFunBloq(s, ctr_show_bloq)))
    })
  })


  test_that("Create a plot with not valid dname throw  message", {
    ctr <- pmxClassHelpers$ctr
    expect_is(ctr, "pmxClass")
    expect_output(
      ctr %>% set_plot("DIS", pname = "distr1", type = "box", dname = "xxx"),
      "No data xxx provided for plot distr1"
    )
  })
}