tests/testthat/test-draw-methods.R

In gavinsimpson/gratia: Graceful 'ggplot'-Based Graphics and Other Functions for GAMs Fitted Using 'mgcv'

## Test draw() methods

test_that("draw.gam works with numeric select", {
  plt1 <- draw(su_m_quick_eg1, select = 2, rug = FALSE)
  plt2 <- draw(su_m_quick_eg1, select = c(1, 2), rug = FALSE)
  skip_on_ci()
  expect_doppelganger("draw gam smooth for selected smooth numeric", plt1)
  expect_doppelganger("draw gam smooth for two selected smooths numeric", plt2)
})

test_that("draw.gam fails with bad select", {
  expect_error(draw(su_m_univar_4, select = 8),
    "One or more indices in 'select' > than the number of smooths in the model.",
    fixed = TRUE
  )
  expect_error(draw(su_m_univar_4, select = c(1, 3, 5, 6)),
    "One or more indices in 'select' > than the number of smooths in the model.",
    fixed = TRUE
  )
  expect_error(draw(su_m_univar_4, select = c(1, 2, 3, 4, 5)),
    "Trying to select more smooths than are in the model.",
    fixed = TRUE
  )
  expect_error(draw(su_m_univar_4, select = TRUE),
    "When 'select' is a logical vector, 'length(select)' must equal
the number of smooths in the model.",
    fixed = TRUE
  )
})

test_that("draw.gam works with character select", {
  plt1 <- draw(su_m_quick_eg1, select = "s(x1)", rug = FALSE)
  plt2 <- draw(su_m_quick_eg1, select = c("s(x0)", "s(x1)"), rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw gam smooth for selected smooth character", plt1)
  expect_doppelganger(
    "draw gam smooth for two selected smooths character",
    plt2
  )
})

test_that("draw.gam works with logical select single smooth", {
  plt <- draw(su_m_quick_eg1,
    select = c(TRUE, rep(FALSE, 3)),
    rug = FALSE
  )
  skip_on_ci()
  expect_doppelganger("draw gam smooth for selected smooth logical", plt)
})

test_that("draw.gam works with logical select two smooths", {
  plt <- draw(su_m_quick_eg1,
    select = rep(c(TRUE, FALSE), each = 2),
    rug = FALSE
  )
  skip_on_ci()
  expect_doppelganger("draw gam smooth for two selected smooths logical", plt)
})

test_that("draw.gam works with partial_match", {
  plt <- draw(su_m_factor_by,
    select = "x2", partial_match = TRUE,
    rug = FALSE, n = 50
  )
  expect_error(draw(su_m_factor_by, select = "s(x2)", partial_match = FALSE),
    "Failed to match any smooths in model `su_m_factor_by`.\nTry with 'partial_match = TRUE'?",
    fixed = TRUE
  )

  skip_on_ci()
  expect_doppelganger("draw gam with partial match TRUE", plt)
})

test_that("draw.gam works with select and parametric", {
  plt1 <- draw(su_m_factor_by,
    select = "s(x2)", partial_match = TRUE,
    rug = FALSE
  )
  plt2 <- draw(su_m_factor_by,
    select = "s(x2)", partial_match = TRUE,
    parametric = FALSE, data = su_eg4, envir = teardown_env(),
    rug = FALSE
  )
  plt3 <- draw(su_m_factor_by,
    select = "s(x2)", partial_match = TRUE,
    parametric = TRUE, data = su_eg4, envir = teardown_env(),
    rug = FALSE
  )
  plt4 <- draw(su_m_factor_by,
    parametric = TRUE, rug = FALSE,
    data = su_eg4, envir = teardown_env()
  )
  plt5 <- draw(su_m_factor_by,
    parametric = FALSE, rug = FALSE,
    data = su_eg4, envir = teardown_env()
  )

  skip_on_ci()
  expect_doppelganger("draw gam with select and parametric is NULL", plt1)
  expect_doppelganger("draw gam with select and parametric is FALSE", plt2)
  expect_doppelganger("draw gam with select and parametric is TRUE", plt3)
  expect_doppelganger("draw gam without select and parametric is TRUE", plt4)
  expect_doppelganger("draw gam without select and parametric is FALSE", plt5)
})

test_that("draw.gam() plots a simple multi-smooth AM", {
  plt1 <- draw(su_m_quick_eg1, rug = FALSE)
  plt2 <- draw(su_m_quick_eg1, scales = "fixed", rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw simple multi-smooth AM", plt1)
  expect_doppelganger("draw simple multi-smooth AM with fixed scales", plt2)
})

test_that("draw.gam() can draw partial residuals", {
  plt1 <- draw(m_tiny_eg1, residuals = TRUE, rug = FALSE)
  plt2 <- draw(m_tiny_eg1, residuals = TRUE, scales = "fixed", rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw simple partial residuals", plt1)
  expect_doppelganger("draw simple partial residuals with fixed scales", plt2)
})

test_that("draw.gam() plots an AM with a single 2d smooth", {
  skip_on_os("mac")
  skip_on_os("windows")
  plt <- draw(su_m_bivar, n = 50, rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw AM with 2d smooth", plt)
})

test_that("draw.gam() plots an AM with a single factor by-variable smooth", {
  plt1 <- draw(su_m_factor_by, rug = FALSE)
  plt2 <- draw(su_m_factor_by, scales = "fixed", rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw AM with factor by-variable smooth", plt1)
  expect_doppelganger("draw factor by-variable smooth with fixed scales", plt2)
})

test_that("draw() works with continuous by", {
  plt <- draw(su_m_cont_by, rug = FALSE, n = 50)
  skip_on_ci()
  expect_doppelganger("draw with continuous by-variable smooth", plt)
})

test_that("draw() works with continuous by and fixed scales", {
  plt <- draw(su_m_cont_by, scales = "fixed", rug = FALSE, n = 50)
  skip_on_ci()
  expect_doppelganger("draw with continuous by-var fixed scale", plt)
})

test_that("draw() works with random effect smooths (bs = 're')", {
  p2 <- draw(rm1, ncol = 3, rug = FALSE)
  p3 <- draw(rm1, ncol = 3, scales = "fixed", rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw.gam model with ranef smooth", p2)
  expect_doppelganger("draw model with ranef smooth fixed scales", p3)
})

test_that("draw() with random effect smooths (bs = 're') & factor by variable ", {
  p2 <- draw(rm2, ncol = 3, rug = FALSE)
  p3 <- draw(rm2, ncol = 3, scales = "fixed", rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw.gam model with ranef smooth factor by", p2)
  expect_doppelganger("draw with ranef smooth factor by fixed scales", p3)
})

test_that("draw() can handle non-standard names -- a function call as a name", {
  df <- data.frame(
    y = c(
      0.15, 0.17, 0.07, 0.17, 0.01, 0.15, 0.18, 0.04, -0.06, -0.08,
      0, 0.03, -0.27, -0.93, 0.04, 0.12, 0.08, 0.15, 0.04, 0.15,
      0.03, 0.09, 0.11, 0.13, -0.11, -0.32, -0.7, -0.78, 0.07, 0.04,
      0.06, 0.12, -0.15, 0.05, -0.08, 0.14, -0.02, -0.14, -0.24,
      -0.32, -0.78, -0.81, -0.04, -0.25, -0.09, 0.02, -0.13, -0.2,
      -0.04, 0, 0.02, -0.05, -0.19, -0.37, -0.57, -0.81
    ),
    time = rep(2^c(
      -1, 0, 1, 1.58, 2, 2.58, 3, 3.32, 3.58, 4.17,
      4.58, 5.58, 6.17, 7.39
    ), 4)
  )
  ## the smooth is of `log2(time)` but this needs special handling
  ## in the `ggplot()` to avoid `ggplot()` looking incorrectly for `time` and
  ## not the correct `log2(time)`
  fit <- gam(y ~ s(log2(time)), data = df, method = "REML")
  p1 <- draw(fit)
  skip_on_ci()
  expect_doppelganger("draw.gam model with non-standard names", p1)
})

test_that("draw() works with factor-smooth interactions (bs = 'fs')", {
  # skip_on_os("mac") # try without this and check on Simon's mac system
  skip_on_ci()
  skip_if(packageVersion("mgcv") < "1.8.36")
  p2 <- draw(mod_fs, ncol = 2, rug = FALSE)
  p3 <- draw(mod_fs, ncol = 2, scales = "fixed", rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw.gam model with fs smooth", p2)
  expect_doppelganger("draw model with fs smooth fixed scales", p3)
})

test_that("draw() works with parametric terms", {
  ## fake some data...
  df <- withr::with_seed(0, {
    f1 <- function(x) {
      exp(2 * x)
    }
    f2 <- function(x) {
      0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10
    }
    f3 <- function(x) {
      x * 0
    }

    n <- 200
    sig2 <- 4
    x0 <- rep(1:4, 50)
    x1 <- runif(n, 0, 1)
    x2 <- runif(n, 0, 1)
    x3 <- runif(n, 0, 1)
    e <- rnorm(n, 0, sqrt(sig2))
    y <- 2 * x0 + f1(x1) + f2(x2) + f3(x3) + e
    data.frame(x0 = x0, x1 = x1, x2 = x2, x3 = x3, y = y)
  })

  ## fit
  mod <- gam(y ~ x0 + s(x1) + s(x2) + s(x3), data = df)


  skip_if_not_installed("withr")
  withr::local_options(lifecycle_verbosity = "quiet")

  ## evaluate parametric terms directly
  e1 <- evaluate_parametric_term(mod, term = "x0")
  expect_s3_class(e1, "evaluated_parametric_term")
  expect_equal(ncol(e1), 5L)
  expect_named(e1, c("term", "type", "value", "partial", "se"))
  p1 <- draw(e1, rug = FALSE)

  ## check evaluate_parametric_term works
  p2 <- draw(mod, rug = FALSE)

  ## factor parametric terms
  x0 <- factor(x0)
  df <- data.frame(x0 = x0, x1 = x1, x2 = x2, x3 = x3, y = y)
  ## fit
  mod <- gam(y ~ x0 + s(x1) + s(x2) + s(x3), data = df)

  ## check evaluate_parametric_term works
  p3 <- draw(mod, rug = FALSE)

  ## evaluate parametric terms directly
  e2 <- evaluate_parametric_term(mod, term = "x0")
  expect_s3_class(e2, "evaluated_parametric_term")

  expect_error(evaluate_parametric_term(mod, term = "x1"),
    "Term is not in the parametric part of model: <x1>",
    fixed = TRUE
  )

  expect_warning(evaluate_parametric_term(mod, term = c("x0", "x1")),
    "More than one `term` requested; using the first <x0>",
    fixed = TRUE
  )

  skip_on_ci()
  expect_doppelganger("draw with linear parametric term", p1)
  expect_doppelganger("draw.gam with linear parametric term", p2)
  expect_doppelganger("draw.gam with factor parametric term", p3)
})

test_that("component-wise CIs work without seWithMean", {
  plt <- draw(su_m_univar_4, overall_uncertainty = FALSE, rug = FALSE)

  skip_on_ci()
  expect_doppelganger("draw gam with overall_uncertainty false", plt)
})

test_that("draw.derivates() plots derivatives for a GAM", {
  skip_on_ci()

  d1 <- derivatives(su_m_univar_4, type = "central", n = 200)
  plt1 <- draw(d1)
  plt2 <- draw(d1, scales = "fixed")

  skip_on_ci()
  expect_doppelganger("draw derivatives for a GAM", plt1)
  expect_doppelganger("draw derivatives for a GAM with fixed scales", plt2)
})

test_that("draw.derivates plots derivatives with change indicators", {
  # not on CRAN
  skip_on_cran()
  skip_on_ci() # causing trivial failures on GH

  d1 <- derivatives(m_gam, type = "central", n = 200)
  expect_silent(plt1 <- draw(d1, add_change = TRUE))
  expect_silent(plt2 <- draw(d1, add_change = TRUE, change_type = "sizer"))

  skip_on_ci()
  expect_doppelganger("draw derivatives for a GAM with default change", plt1)
  expect_doppelganger("draw derivatives for a GAM with sizer change", plt2)
})

test_that("draw.derivates() plots derivatives for a GAM rotated labels", {
  skip_on_cran()
  d1 <- derivatives(su_m_univar_4, type = "central", n = 100)
  plt1 <- draw(d1, angle = 45)
  plt2 <- draw(d1, scales = "fixed", angle = 45)

  skip_on_ci()
  expect_doppelganger("draw derivatives for a GAM rotated labels", plt1)
  expect_doppelganger(
    "draw derivatives for a GAM with fixed scales rotated",
    plt2
  )
})

test_that("draw plots partial derivatives for a GAM", {
  d1 <- partial_derivatives(su_m_bivar_te,
    select = "te(x,z)", focal = "z",
    type = "central", n = 100
  )
  plt1 <- draw(d1)

  plt2 <- draw(d1, scales = "fixed")

  skip_on_ci()
  expect_doppelganger("draw partial derivatives for a GAM", plt1)
  expect_doppelganger(
    "draw partial derivatives for a GAM with fixed scales",
    plt2
  )
})

test_that("draw plots partial derivs for GAM rotated labels", {
  skip_on_cran()
  d1 <- partial_derivatives(su_m_bivar_te,
    select = "te(x,z)", focal = "z",
    type = "central", n = 100
  )
  plt1 <- draw(d1, angle = 45)
  plt2 <- draw(d1, scales = "fixed", angle = 45)

  skip_on_ci()
  expect_doppelganger(
    "draw partial derivatives for GAM rotated labels",
    plt1
  )
  expect_doppelganger(
    "draw partial derivatives for GAM fixed scales rotated",
    plt2
  )
})

## test that issue 39 stays fixed
test_that("draw.gam doesn't create empty plots with multiple parametric terms", {
  plt <- draw(m_2_fac, rug = FALSE)
  skip_on_ci()
  expect_doppelganger("draw issue 39 empty plots", plt)
})

test_that("draw.mgcv_smooth() can plot basic smooth bases", {
  skip_on_cran()
  skip_on_ci() # sign differences due to eigendecomposition in TPRS

  bs <- basis(s(x0), data = quick_eg1)
  plt <- draw(bs)
  skip_on_ci()
  expect_doppelganger("draw basic tprs basis", plt)
})

test_that("draw.mgcv_smooth() can plot basic smooth bases with rotated labels", {
  skip_on_cran()
  skip_on_ci() # sign differences due to eigendecomposition in TPRS

  bs <- basis(s(x0), data = quick_eg1)
  plt <- draw(bs, angle = 45)
  skip_on_ci()
  expect_doppelganger("draw basic tprs basis rotated", plt)
})

test_that("draw.mgcv_smooth() can plot by factor basis smooth bases", {
  bs <- basis(s(x2, by = fac), data = su_eg4)
  plt <- draw(bs)

  skip_on_ci()
  skip_on_cran()
  expect_doppelganger("draw by factor basis", plt)
})

test_that("draw() works with a ziplss models; issue #45", {
  plt <- draw(m_ziplss, rug = FALSE)
  skip_on_ci()
  expect_doppelganger("draw ziplss parametric terms issue 45", plt)
})

test_that("draw works for sample_smooths objects", {
  skip_on_cran()
  skip_on_ci() # minor statistical differences

  sm1 <- smooth_samples(su_m_univar_4, n = 5, seed = 23478, n_vals = 50)
  plt1 <- draw(sm1, alpha = 0.7, n_samples = 5, seed = 2635, rug = FALSE)

  sm2 <- smooth_samples(su_m_bivar, n = 4, seed = 23478, n_vals = 50)
  plt2 <- draw(sm2, alpha = 0.7, n_samples = 4, seed = 2635)

  sm3 <- smooth_samples(su_m_factor_by, n = 5, seed = 23478, n_vals = 50)
  plt3 <- draw(sm3, alpha = 0.7, n_samples = 5, seed = 2635, rug = FALSE)

  sm3 <- smooth_samples(su_m_factor_by, n = 5, seed = 23478, n_vals = 50)
  plt4 <- draw(sm3,
    alpha = 0.7, scales = "fixed", n_samples = 10,
    seed = 2635, rug = FALSE
  )

  skip_on_ci()
  expect_doppelganger("draw smooth_samples for GAM m1", plt1)
  expect_doppelganger("draw smooth_samples for GAM m2", plt2)
  expect_doppelganger("draw smooth_samples for GAM m3", plt3)
  expect_doppelganger("draw smooth_samples for GAM m3 fixed scales", plt4)
})

test_that("draw works for sample_smooths objects rotated labels", {
  skip_on_cran()
  skip_on_ci() # minor statistical differences

  sm1 <- smooth_samples(su_m_univar_4, n = 5, seed = 23478, n_vals = 50)
  plt1 <- draw(sm1,
    alpha = 0.7, n_samples = 5, seed = 2635, angle = 45,
    rug = FALSE
  )

  sm2 <- smooth_samples(su_m_bivar, n = 4, seed = 23478, n_vals = 50)
  plt2 <- draw(sm2,
    alpha = 0.7, n_samples = 4, seed = 2635, angle = 45,
    rug = FALSE
  )

  sm3 <- smooth_samples(su_m_factor_by, n = 5, seed = 23478, n_vals = 50)
  plt3 <- draw(sm3,
    alpha = 0.7, n_samples = 5, seed = 2635, angle = 45,
    rug = FALSE
  )

  sm3 <- smooth_samples(su_m_factor_by, n = 5, seed = 23478, n_vals = 50)
  plt4 <- draw(sm3,
    alpha = 0.7, scales = "fixed", n_samples = 5, seed = 2635,
    angle = 45, rug = FALSE
  )

  skip_on_ci()
  expect_doppelganger("draw smooth_samples for GAM m1 rotated", plt1)
  expect_doppelganger("draw smooth_samples for GAM m2 rotated", plt2)
  expect_doppelganger("draw smooth_samples for GAM m3 rotated", plt3)
  expect_doppelganger(
    "draw smooth_samples for GAM m3 fixed scales rotated",
    plt4
  )
})

test_that("draw works for smooth_samples objects", {
  skip_on_os("win")
  skip_on_os("mac")
  sm2 <- smooth_samples(su_m_bivar, n = 2, seed = 23478, n_vals = 50)
  plt <- draw(sm2, alpha = 0.7, contour = TRUE)

  skip_on_ci()
  expect_doppelganger("draw smooth_samples for bivariate GAM contours", plt)
})

test_that("draw works for sample_smooths objects with n_samples", {
  skip_on_cran()
  skip_on_ci() # minor statistical differences

  sm1 <- smooth_samples(su_m_univar_4, n = 5, seed = 23478, n_vals = 50)
  plt1 <- draw(sm1, alpha = 0.7, n_samples = 3, rug = FALSE, seed = 1)

  sm2 <- smooth_samples(su_m_bivar, n = 4, seed = 23478, n_vals = 50)
  plt2 <- draw(sm2, alpha = 0.7, n_samples = 2, rug = FALSE, seed = 14)

  sm3 <- smooth_samples(su_m_factor_by, n = 5, seed = 23478, n_vals = 50)
  plt3 <- draw(sm3, alpha = 0.7, n_samples = 3, rug = FALSE, seed = 19)

  skip_on_ci()
  expect_doppelganger("draw smooth_samples for m1 n_samples", plt1)
  expect_doppelganger("draw smooth_samples for m2 n_samples", plt2)
  expect_doppelganger("draw smooth_samples for GAM n_samples", plt3)
})

test_that("draw works for sample_smooths objects with user specified smooth", {
  skip_on_cran()
  skip_on_ci() # minor statistical differences

  sm3 <- smooth_samples(su_m_factor_by, n = 5, seed = 23478, n_vals = 50)
  plt1 <- draw(sm3, select = "s(x0)", alpha = 0.7, rug = FALSE)

  plt2 <- draw(sm3,
    select = "s(x2)", alpha = 0.7, partial_match = TRUE,
    rug = FALSE
  )

  skip_on_ci()
  expect_doppelganger(
    "draw selected factor by smooth_samples for GAM m3",
    plt2
  )
  expect_doppelganger("draw selected smooth_samples for GAM m3", plt1)
})

## Issue #22
test_that("draw() can handle a mixture of numeric and factor random effects", {
  df <- data_sim("eg4", seed = 42)
  m <- gam(y ~ s(x2, fac, bs = "re"), data = df, method = "REML")
  plt <- draw(m)

  skip_on_ci()
  expect_doppelganger("issue 22 draw with mixed random effects", plt)
})

test_that("draw.gam uses fixed scales if asked for them: #73", {
  skip_on_cran()
  skip_on_ci()
  df <- data_sim("eg1", n = 1000, seed = 1)
  m <- gam(y ~ s(x1) + s(x2) + ti(x1, x2), data = su_eg1, method = "REML")
  plt <- draw(m, scales = "fixed", rug = FALSE)

  skip_on_ci()
  expect_doppelganger(
    "issue 73 draw uses fixed scales if asked for them",
    plt
  )
})

test_that("draw.gam can take user specified scales", {
  skip_on_os(os = "win")
  skip_on_os(os = "mac") # trivial diffs in contours
  plt1 <- draw(su_m_bivar,
    rug = FALSE,
    continuous_fill = scale_fill_distiller(
      palette = "Spectral",
      type = "div"
    )
  )

  skip_if(packageVersion("mgcv") < "1.8.36")
  plt2 <- draw(mod_fs,
    rug = FALSE,
    discrete_colour = ggplot2::scale_colour_viridis_d(option = "plasma")
  )

  skip_on_ci()
  expect_doppelganger("draw 2d smooth with spectral palette", plt1)

  skip_if(packageVersion("mgcv") < "1.8.36")
  expect_doppelganger(
    "draw fs smooth with discrete plasma palette",
    plt2
  )
})

test_that("plotting sos smooths works", {
  skip_on_cran()
  skip_if_not_installed("sf")
  skip_on_os("mac")
  expect_silent(plt <- draw(m_sos, n = 20))

  skip_on_ci()
  expect_doppelganger("draw works for sos smooths", plt)
})