tests/testthat/test-pmx-plot-vpc.R

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

if (helper_skip()) {

  library(ggPMX)
  library(ggplot2)
  library(purrr)
  ctr <- theophylline()

  context("Test pmx_plot_vpc function")

  #------------------- pmx_plot_vpc - start -------------------------------------

  test_that("pmx_plot_vpc: params: ctr, is.footnote; result: ggplot", {
    p <- pmx_plot_vpc(ctr, is.footnote = FALSE)
    expect_s3_class(p, "ggplot")
  })

  test_that("pmx_plot_vpc: params: ctr, strat.facet; result: ggplot", {
    p <- pmx_plot_vpc(ctr, strat.facet = ~STUD)
    expect_s3_class(p, "ggplot")
  })

  test_that("pmx_plot_vpc: params: ctr; result: ggplot", {
    p <- pmx_plot_vpc(ctr)
    expect_s3_class(p, "ggplot")
  })

  test_that("pmx_plot_vpc: params: ctr, bin; result: ggplot", {
    p <- pmx_plot_vpc(ctr, bin = pmx_vpc_bin(style = "equal"))
    expect_s3_class(p, "ggplot")
  })

  test_that("custom labels are applied to pmx_plot_vpc", {
    ctr <- theophylline()
    p <- pmx_plot_vpc(ctr, labels = c(x = "custom axis x", y = "custom axis y"))
    expect_identical(p[["labels"]][["x"]], "custom axis x")
    expect_identical(p[["labels"]][["y"]], "custom axis y")
  })

  test_that("pmx_plot_vpc: params NULL result: error missing arguments", {
    expect_error(pmx_plot_vpc())
  })


  test_that("pmx_plot_vpc: params ctr result: identical names", {
    p <- pmx_plot_vpc(ctr)
    vpcNames <- c(
      "data", "layers", "scales", "mapping", "theme", "coordinates",
      "facet", "plot_env", "labels"
    )
    expect_identical(names(p), vpcNames)
  })


  test_that("pmx_plot_vpc: params NULL result: identical type", {
    p <- ctr %>% pmx_plot_vpc()
    expect_true(inherits(p, "ggplot"))
    expect_identical(p$plot_env$type, "percentile")
    expect_identical(p$plot_env$idv, "TIME")
  })


  test_that("pmx_plot_vpc: params result: ggplot", {
    p <- ctr %>% pmx_plot_vpc(strat.facet = "SEX", facets = list(nrow = 2), type = "scatter")
    expect_true(inherits(p, "ggplot"))
  })


  test_that("pmx_plot_vpc: params result: identical type", {
    p <- ctr %>% pmx_plot_vpc(strat.facet = "SEX", facets = list(nrow = 2), type = "scatter")
    expect_identical(p$plot_env$type, "scatter")
  })


  test_that("pmx_plot_vpc: params result: ggplot, identical median", {
    vpc <- ctr %>% pmx_plot_vpc(
      is.legend = TRUE,
      pi = pmx_vpc_pi(interval = c(0.02, 0.98), median = list(linetype = "dotted")),
      ci = pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red"))
    )
    expect_true(inherits(vpc, "ggplot"))
    expect_true(identical(vpc$plot_env$pi$median$linetype, "dotted"))
    expect_true(identical(vpc$plot_env$ci$median$fill, "red"))
  })

  #------------------- pmx_plot_vpc - end ---------------------------------------

  #------------------- pmx_vpc_pi - start ---------------------------------------

  context("Test pmx_vpc_pi function")

  test_that("pmx_vpc_pi: params result: 'pmx_vpc_pi', 'list'", {
    pi <- pmx_vpc_pi(interval = c(0.02, 0.98), median = list(linetype = "dotted"))
    expect_true(inherits(pi, c("pmx_vpc_pi", "list")))
  })


  test_that("pmx_vpc_pi: params NULL result: 'pmx_vpc_pi', 'list'", {
    pi <- pmx_vpc_pi()
    expect_true(inherits(pi, c("pmx_vpc_pi", "list")))
  })


  test_that("pmx_vpc_pi: params result: elements in the list", {
    piNames <- c("show", "probs", "median", "extreme", "area")
    expect_true(all(piNames %in% names(pmx_vpc_pi())))
  })


  test_that("pmx_vpc_pi: params result: identical structure", {
    pi <- pmx_vpc_pi()
    area_default <- list(fill = "blue", alpha = 0.1)
    expect_identical(pi$area, area_default)
  })

  #------------------- pmx_vpc_pi - end -----------------------------------------

  #------------------- pmx_vpc_obs - start --------------------------------------

  context("Test pmx_vpc_obs function")

  test_that("pmx_vpc_obs: params result: 'pmx_vpc_obs', 'list'", {
    obs <- pmx_vpc_obs(show = TRUE, color = "#000000", size = 1, alpha = 0.7, shape = 1)
    expect_true(inherits(obs, c("pmx_vpc_obs", "list")))
  })


  test_that("pmx_vpc_obs: params NULL result: 'pmx_vpc_obs', 'list'", {
    obs <- pmx_vpc_obs()
    expect_true(inherits(obs, c("pmx_vpc_obs", "list")))
  })


  test_that("pmx_vpc_obs: params result: elements in the list", {
    obsNames <- c("color", "size", "alpha", "shape")
    expect_true(all(obsNames %in% names(pmx_vpc_obs())))
  })


  test_that("pmx_vpc_obs: params result: NULL", {
    expect_true(is.null(names(pmx_vpc_obs(show = FALSE))))
  })

  #------------------- pmx_vpc_obs - end ----------------------------------------

  #------------------- pmx_vpc_ci - start ---------------------------------------

  context("Test pmx_vpc_ci function")

  test_that("pmx_vpc_ci: params result: 'pmx_vpc_ci', 'list'", {
    ci <- pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red"))
    expect_true(inherits(ci, c("pmx_vpc_ci", "list")))
  })


  test_that("pmx_vpc_ci: params NULL result: 'pmx_vpc_ci', 'list'", {
    ci <- pmx_vpc_ci()
    expect_true(inherits(ci, c("pmx_vpc_ci", "list")))
  })


  test_that("pmx_vpc_ci: params NULL result: elements in the list", {
    ciNames <- c("show", "probs", "method", "median", "extreme")
    expect_true(all(ciNames %in% names(pmx_vpc_ci())))
  })


  test_that("pmx_vpc_ci: params result: elements in the list", {
    ci <- pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red"))
    expect_identical(ci$probs, c(0.05, 0.95))
    expect_identical(ci$median$fill, "red")
  })

  test_that("pmx_vpc_ci: params result: error", {
    expect_error(pmx_vpc_ci(method = "triangle", median = list(fill = "red")))
  })

  #------------------- pmx_vpc_ci - end -----------------------------------------

  #------------------- pmx_vpc_rug - start --------------------------------------

  context("Test pmx_vpc_rug function")

  test_that("pmx_vpc_rug: params result: 'pmx_vpc_rug', 'list'", {
    obs <- pmx_vpc_rug(show = TRUE, color = "#000000", linewidth = 1, alpha = 0.7)
    expect_true(inherits(obs, c("pmx_vpc_rug", "list")))
  })


  test_that("pmx_vpc_rug: params NULL result: 'pmx_vpc_rug', 'list'", {
    obs <- pmx_vpc_rug()
    expect_true(inherits(obs, c("pmx_vpc_rug", "list")))
  })


  test_that("pmx_vpc_rug: params result: elements in the list", {
    obsNames <- c("color", "linewidth", "alpha")
    expect_true(all(obsNames %in% names(pmx_vpc_rug())))
  })


  test_that("pmx_vpc_rug: params result: NULL", {
    expect_true(is.null(names(pmx_vpc_rug(show = FALSE))))
  })

  #------------------- pmx_vpc_rug - end ----------------------------------------

  #------------------- quantile_dt - start --------------------------------------

  test_that("quantile_dt: params: NULL; result: missing arguments", {
    expect_error(quantile_dt())
  })

  #------------------- quantile_dt - end ----------------------------------------

  #------------------- pmx_vpc - start --------------------------------------

  test_that("pmx_vpc: params: NULL; result: identical inherits", {
    vpc <- pmx_vpc()
    expect_true(inherits(vpc, c("pmx_vpc", "pmx_gpar")))
    expect_true(inherits(vpc$pi, c("pmx_vpc_pi", "list")))
  })


  test_that("pmx_vpc: params: NULL; result: identical structure", {
    vpc <- pmx_vpc()
    expect_identical(vpc$ptype, "VPC")
    expect_true(vpc$strat)
  })

  test_that("pmx_vpc: params: type; result: identical structure (default type)", {
    vpc <- pmx_vpc(type = "percent")
    expect_identical(vpc$type, "percentile")
  })

  #------------------- pmx_vpc - end ----------------------------------------

  #------------------- vpc_footnote. - start --------------------------------------

  test_that("vpc_footnote.: params: x; result: identical inherits", {
    vpc <- pmx_vpc()
    vpc_f <- vpc_footnote.(vpc)
    expect_true(inherits(vpc_f, c("pmx_vpc", "pmx_gpar")))
    expect_true(inherits(vpc_f$ci, c("pmx_vpc_ci", "list")))
    expect_true(inherits(vpc_f$footnote, "character"))
  })

  test_that("vpc_footnote.: params: x; result: identical structure", {
    vpc <- pmx_vpc()
    vpc_f <- vpc_footnote.(vpc)
    expect_identical(vpc_f$gp$smooth$linetype, 1)
    expect_identical(vpc_f$gp$legend.position, "right")
  })

  test_that("vpc_footnote.: params: x; result: error", {
    vpc <- ""
    expect_error(vpc_footnote.(vpc))
  })

  #------------------- vpc_footnote. - end ---------------------------------------

  #------------------- vpc_legend. - start ---------------------------------------
  #
  test_that("vpc_legend.: params: x; result: identical structure", {
    vpc <- pmx_vpc(labels=list(title="x"))
    vpc_l <- vpc_legend.(vpc)
    expect_identical(vpc_l$ptype, "VPC")
    expect_identical(vpc_l$rug$alpha, 0.7)
  })

  test_that("vpc_legend.: params: x; result: identical inherits", {
    vpc <- pmx_vpc(labels=list(title="x"))
    vpc_l <- vpc_legend.(vpc)
    expect_true(inherits(vpc_l, c("pmx_vpc", "pmx_gpar")))
  })

  test_that("vpc_legend.: params: x; result: identical names", {
    vpc <- pmx_vpc(labels=list(title="x"))
    vpc_l <- vpc_legend.(vpc)
    vpslNames <- c(
      "ptype", "strat", "idv", "dname", "labels", "is.legend", "is.footnote",
      "type", "facets", "obs", "pi", "ci", "rug", "bin",
      "gp", "obs_legend", "sim_legend"
    )

    expect_identical(names(vpc_l), vpslNames)
  })
  #------------------- vpc_legend. - end -----------------------------------------

  #------------------- plot_pmx.pmx_vpc - start ----------------------------------

  test_that("plot_pmx.pmx_vpc: params: x; result: error missing arguments", {
    expect_error(plot_pmx.pmx_vpc())
  })

  #------------------- plot_pmx.pmx_vpc - end ------------------------------------
}