test-plot-residual.R
In ggPMX: 'ggplot2' Based Tool to Facilitate Diagnostic Plots for NLME Models

context("Test residual function")

ctr <- theophylline()

#------------------- pmx_plot_iwres_ipred start ------------------------------
test_that("residual: params: x equals IWRES, y equals IPRED;
          result: identical structure",
  {
    x <- "IWRES"
    y <- "IPRED"
    aess <- list(x = x, y = y)
    labels <- list(
      title = paste(rev(aess), collapse = " versus "),
      subtitle = "",
      x = aess[["x"]],
      y = aess[["y"]]
    )
    expect_identical(residual(x, y),
      structure(
        list(
          ptype = "SCATTER",
          strat = TRUE,
          dname = "predictions",
          aess = aess,
          point = list(
            shape = 1,
            colour = "black",
            size = 1
          ),
          is.hline = FALSE,
          hline = list(yintercept = 0),
          facets = NULL,
          bloq = NULL,
          square_plot = TRUE,
          gp = pmx_gpar(labels = labels)
      ),
      class = c("residual", "pmx_gpar")
    ))
})

#------------------- residual start ------------------------------------------

test_that("residual: params: x, y; result: error x, y is missing ", {
  x <- "IWRES"
  y <- "IPRED"
  expect_error(residual(y))
  expect_error(residual(x))
})

test_that("residual: params: x, y, ect.; result: error labels, point, hline are not list ot NULL ", {
  x <- "IWRES"
  y <- "IPRED"
  expect_error(residual(x, y, labels = 1))
  expect_error(residual(x, y, point = 1))
  expect_error(residual(x, y, hline = TRUE))
})

test_that("residual: params: x, y, ect.; result: error dname is not string ot NULL ", {
  x <- "IWRES"
  y <- "IPRED"
  expect_error(residual(x, y, dname = 1))
})

test_that("residual: params: x, y, dname = NULL; result: identical structure", {
  x <- "IWRES"
  y <- "IPRED"
  default_point <- list(shape = 1, colour = "black", size = 1)
  res <- residual(x, y)
  expect_identical(res$dname, "predictions")
  expect_identical(res$point, default_point)
})

test_that("residual: params: x, y; result: identical inherits", {
  x <- "IWRES"
  y <- "IPRED"
  res <- residual(x, y)
  expect_true(inherits(res, c("residual", "pmx_gpar")))
})

test_that("residual: params: x, y; result: identical names", {
  x <- "IWRES"
  y <- "IPRED"
  res <- residual(x, y)
  resNames <- c(
    "ptype", "strat", "dname", "aess", "point", "is.hline",
    "hline", "facets", "bloq", "square_plot", "gp"
  )
  expect_identical(names(res), resNames)
})


#------------------- residual end ------------------------------------------

#------------------- extend_range start ------------------------------------

test_that("extend_range: params: x; result: identical range", {
  dx <- ctr %>% get_data("omega")
  expect_identical(extend_range(x = dx), c(Inf, -Inf))
})

test_that("extend_range: params: x; result: error 'r' must be a 'range', hence of length 2", {
  dx <- ctr %>% get_data("omega")
  expect_error(extend_range(x = dx, r = Inf))
})

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

test_that("extend_range: params: x; result: error data frame should has all numeric variables", {
  dx <- ctr %>% get_data("eta")
  dx <- dx[, EFFECT := factor(
    EFFECT,
    levels = c("ka", "V", "Cl"),
    labels = c("Concentration", "Volume", "Clearance")
  )]
  expect_error(extend_range(x = dx[, c(aess$x, aess$y), with = FALSE]))
})

#------------------- extend_range end --------------------------------------

#------------------- plot_pmx.residual start -------------------------------

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

test_that("plot_pmx.residual: params: x, dx; result: NULL", {
  x <- "IWRES"
  y <- "IPRED"
  dx <- ctr %>% get_data("eta")
  dx <- dx[, EFFECT := factor(
    EFFECT,
    levels = c("ka", "V", "Cl"),
    labels = c("Concentration", "Volume", "Clearance")
  )]
  res <- residual(x, y)
  expect_identical(plot_pmx.residual(x = res, dx), NULL)
})

test_that("plot_pmx.residual: params: x, dx; result: identical structure", {
  x <- "STUD"
  y <- "SEX"
  dx <- ctr %>% get_data("eta")
  dx <- dx[, EFFECT := factor(
    EFFECT,
    levels = c("ka", "V", "Cl"),
    labels = c("Concentration", "Volume", "Clearance")
  )]
  bloq <- pmx_bloq(cens = "EVID")
  bloq$show <- NULL
  res <- residual(x, y, is.hline = TRUE, bloq = bloq)
  pl_resid <- plot_pmx.residual(x = res, dx)
  expect_identical(pl_resid$bloq$cens, NULL)
  expect_identical(pl_resid$bloq$limit, NULL)
  expect_identical(pl_resid$bloq$cens, NULL)
  expect_identical(pl_resid$is.hline, NULL)
})


test_that("plot_pmx.residual: params: x, dx, res$gp$scale_x_log10,  scale_x_log10
          are not NULL; result: identical inherits", {
  x <- "Y"
  y <- "DV"
  dx <- ctr %>% get_data("eta")

  aess <- list(x = "Y", y = "DV")
  res <- residual(x, y, ranges = list(x = c(0, 500)), is.hline = TRUE)
  res$aess$y <- "DV"
  res$gp$scale_x_log10 <- F
  res$gp$scale_y_log10 <- F
  res$gp$ranges$x <- NULL
  res$gp$ranges$y <- NULL
  pl_resid <- plot_pmx.residual(x = res, dx)
  expect_true(inherits(pl_resid, "ggplot"))
})

test_that("plot_pmx.residual: params: x, dx, res$ranges$x is not NULL; result: identical inherits", {
  x <- "Y"
  y <- "DV"
  dx <- ctr %>% get_data("eta")

  aess <- list(x = "Y", y = "DV")
  res <- residual(x, y, ranges = list(x = c(0, 500)), is.hline = TRUE)
  res$aess$y <- "DV"
  res$gp$scale_x_log10 <- F
  res$gp$scale_y_log10 <- F
  pl_resid <- plot_pmx.residual(x = res, dx)
  expect_true(inherits(pl_resid, "ggplot"))
})

test_that("plot_pmx.residual: params: x, dx, res$strat.facet, res$strat.color;
          result: identical inherits", {
  x <- "Y"
  y <- "DV"
  dx <- ctr %>% get_data("eta")

  aess <- list(x = "Y", y = "DV")
  res <- residual(x, y, ranges = list(x = c(0, 500), y = c(0, 100)), is.hline = TRUE)
  res$aess$y <- "DV"
  res$gp$scale_x_log10 <- F
  res$gp$scale_y_log10 <- F
  res$strat.color <- "SEX"
  res$strat.facet <- "STUD"
  pl_resid <- plot_pmx.residual(x = res, dx)
  expect_true(inherits(pl_resid, "ggplot"))
})

#------------------- plot_pmx.residual end ---------------------------------

test_that("pmx_plot_iwres_ipred: params: ctr; result: ggplot", {
  expect_true(inherits(pmx_plot_iwres_ipred(ctr), "ggplot"))
})

test_that("pmx_plot_iwres_ipred: params: ctr; result: list", {
  p <- pmx_plot_iwres_ipred(ctr)
  expect_true(inherits(p$scales$scales, "list"))
})

test_that(
  "pmx_plot_iwres_ipred: params: ctr; result: identical structure",
  {
    p <- pmx_plot_iwres_ipred(ctr)
    expect_identical(
      p$scales$scales[[1]]$limits,
      c(-3.3237, 3.3237)
    )
  }
)

test_that(
  "pmx_plot_iwres_ipred: params: ctr_mlx; result: identical structure",
  {
    mlxpath <- file.path(
      system.file(package = "ggPMX"),
      "testdata",
      "1_popPK_model",
      "project.mlxtran"
    )
    ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing")
    p <- pmx_plot_iwres_ipred(ctr_mlx)
    expect_identical(
      p$scales$scales[[1]]$limits,
      c(-3.7749, 3.7749)
    )
  }
)

test_that("pmx_plot_iwres_ipred: params: strat.facet as formula/character
          result: plot panels", {
  ctr <- theophylline()
  p_formula <- pmx_plot_iwres_ipred(ctr, strat.facet = "SEX")
  expect_equal(levels(ggplot_build(p_formula)[[1]][[1]][["PANEL"]]), c("1", "2"))
  p_char <- pmx_plot_iwres_ipred(ctr, strat.facet = ~SEX)
  expect_equal(levels(ggplot_build(p_char)[[1]][[1]][["PANEL"]]), c("1", "2"))
  p_non_ex <- pmx_plot_iwres_ipred(ctr, strat.facet = ~4)
  expect_equal(levels(ggplot_build(p_non_ex)[[1]][[1]][["PANEL"]]), c("1"))
})

test_that(
  "pmx_plot_iwres_ipred: params: ctr, ylim; result: identical structure",
  {
    p <- pmx_plot_iwres_ipred(ctr) + ylim(-5, 5)
    expect_identical(
      p$scales$scales[[1]]$limits,
      c(-5, 5)
    )
  }
)


#------------------- pmx_plot_iwres_ipred end --------------------------------

#------------------- pmx_plot_npde_time start --------------------------------

test_that(
  "pmx_plot_npde_time: params: ctr, explicit filter; result: identical type",
  {
    p <- ctr %>% pmx_plot_npde_time(filter = "STUD == 1")

    expect_true(inherits(p, "ggplot"))
  }
)


test_that(
  "pmx_plot_npde_time: params: ctr, implicit filter; result: identical type",
  {
    filter_string <- "STUD == 1"
    p <- ctr %>% pmx_plot_npde_time(filter = filter_string)

    expect_true(inherits(p, "ggplot"))
  }
)

#------------------- pmx_plot_npde_time end ----------------------------------

#------------------- pmx_plot_cats start -------------------------------------

test_that(
  "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows",
  {
    p <- ctr %>% pmx_plot_cats("dv_pred",
      strat.facet = ~STUD,
      facets = list(nrow = 2, ncol = 1)
    )

    expect_identical(p[[1]]$facet$params$nrow, 2)
    expect_identical(p[[1]]$facet$params$ncol, 1)
  }
)

test_that(
  "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows",
  {
    p <- ctr %>% pmx_plot_cats("dv_pred", strat.facet = ~STUD)

    expect_identical(p[[1]]$facet$params$nrow, NULL)
    expect_identical(p[[1]]$facet$params$ncol, NULL)
  }
)


test_that(
  "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows",
  {
    p <- ctr %>% pmx_plot_cats("pmx_vpc", strat.facet = ~STUD,
      facets = list(nrow = 2, ncol = 1))

    expect_identical(p[[1]]$facet$params$nrow, 2)
    expect_identical(p[[1]]$facet$params$ncol, 1)
  }
)

test_that(
  "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows",
  {
    p <- ctr %>% pmx_plot_cats("npde_time", strat.facet = ~STUD,
      facets = list(nrow = 2, ncol = 1))

    expect_identical(p[[1]]$facet$params$nrow, 2)
    expect_identical(p[[1]]$facet$params$ncol, 1)
  }
)

test_that(
  "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows",
  {
    p <- ctr %>% pmx_plot_cats("iwres_time", strat.facet = ~STUD,
      facets = list(nrow = 2, ncol = 1))

    expect_identical(p[[1]]$facet$params$nrow, 2)
    expect_identical(p[[1]]$facet$params$ncol, 1)
  }
)

test_that(
  "pmx_plot_dv_ipred: params: ctr, strat.color, point(...);
  result: aesthetic params applied along with strat.color",
  {
    params <- list(alpha=0.1, size=2, stroke=2, shape=23, fill="red")
    p <- do.call(pmx_plot_dv_ipred, list(ctr=ctr, strat.color="WT0", point=params))
    lapply(names(params), function(a) {
      value <- p[["plot_env"]][["point"]][[a]]
      if(inherits(value, "quosure")) {value <- as_label(value)}
      expect_identical(value, params[[a]])
    })
  }
)
#------------------- pmx_plot_cats end --------------------------------------


#------------------- pmx_plot_dv_pred start -------------------------------------

test_that(
  "pmx_plot_dv_pred: params: ctr, range; result: squared by default, with
   applied ranges with square_plot = FALSE",
  {
    ctr <- theophylline()
    p1 <- ctr %>% pmx_plot_dv_pred(ranges = list(x = c(200, 500), y = c(100, 200)))

    p2 <- ctr %>% pmx_plot_dv_pred(
                    ranges = list(x = c(200, 500), y = c(100, 200)),
                    square_plot = FALSE
                  )

    expect_equal(
      p1[["plot_env"]][["gp"]][["ranges"]][["y"]][[2]],
      p1[["plot_env"]][["gp"]][["ranges"]][["x"]][[2]]
    )

    expect_equal(p2[["plot_env"]][["gp"]][["ranges"]][["x"]], c(200, 500))
    expect_equal(p2[["plot_env"]][["gp"]][["ranges"]][["y"]], c(100, 200))
  }
)

#------------------- pmx_plot_dv_pred end --------------------------------------