tests/testthat/test-gf_model-visual.R

In coursekata: Packages and Functions for 'CourseKata' Courses

# No predictor -------------------------------------------------------------------------------

test_that("it plots the empty model as a horizontal line when outcome is on Y, two axis plots", {
  gf_point(later_anxiety ~ base_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ NULL, data = er)) %>%
    expect_doppelganger("[gf_point] null mod., y on Y")
})

test_that("it plots the empty model as a vertical line when outcome is on Y, one axis plot", {
  # I know that the plot has two axes, but I only specify one, that's why "one" axis plot
  snap_name <- function(plot_name, suffix = "") {
    glue("[{plot_name}] null mod., y on Y")
  }

  plot_args <- list(gformula = ~later_anxiety, color = ~condition, data = er)

  # skip these funs because their related stat can't be found when running in testthat
  # but these stat funs are in ggstance, so idk... if you're here and you're worried, just
  # test by hand because it usually only doesn't work in testthat
  # bin_plots <- c("gf_histogramh", "gf_dhistogramh")
  other_plots <- c("gf_rugy")
  purrr::walk(other_plots, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ NULL, data = er), color = "brown") %>%
      expect_doppelganger(snap_name(plot))
  })

  # box/violin plots have different formulae
  gf_boxplot(later_anxiety ~ 1, data = er) %>%
    gf_model(lm(later_anxiety ~ NULL, data = er)) %>%
    expect_doppelganger(snap_name("gf_boxplot", " -- 2"))

  testthat::skip_if(Sys.getenv("CI") == "true", "Skipping these tests on GitHub Actions.")

  gf_violin(later_anxiety ~ 1, data = er) %>%
    gf_model(lm(later_anxiety ~ NULL, data = er)) %>%
    expect_doppelganger(snap_name("gf_violin"))
})

test_that("it plots the empty model as a horizontal line when outcome is on X, two axis plot", {
  gf_point(base_anxiety ~ later_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ NULL, data = er)) %>%
    expect_doppelganger("[gf_point] null mod., y on X")
})

test_that("it plots the empty model as a vertical line when outcome is on X, one axis plot", {
  # I know that the plot has two axes, but I only specify one, that's why "one" axis plot
  snap_name <- function(plot_name, suffix = "") {
    glue("[{plot_name}] mull mod., y on X{suffix}")
  }

  plot_args <- list(gformula = ~later_anxiety, color = ~condition, data = er)

  bin_plots <- c("gf_histogram", "gf_dhistogram", "gf_freqpoly")
  purrr::walk(bin_plots, function(plot) {
    do.call(plot, append(plot_args, list(bins = 30))) %>%
      gf_model(lm(later_anxiety ~ NULL, data = er), color = "brown") %>%
      expect_doppelganger(snap_name(plot))
  })

  # box/violin plots have different formulae
  gf_boxplot(~later_anxiety, data = er) %>%
    gf_model(lm(later_anxiety ~ NULL, data = er)) %>%
    expect_doppelganger(snap_name("gf_boxplot"))


  testthat::skip_if(Sys.getenv("CI") == "true", "Skipping these tests on GitHub Actions.")

  gf_violin(1 ~ later_anxiety, data = er) %>%
    gf_model(lm(later_anxiety ~ NULL, data = er)) %>%
    expect_doppelganger(snap_name("gf_violin", " -- 2"))

  gf_violin(later_anxiety ~ 1, data = er) %>%
    gf_model(lm(later_anxiety ~ NULL, data = er)) %>%
    expect_doppelganger(snap_name("gf_violin horizontal"))

  # TODO: "gf_dens2": Can't find geom called "density_line"
  other_plots <- c("gf_rug", "gf_rugx", "gf_density", "gf_dens")
  purrr::walk(other_plots, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ NULL, data = er), color = "brown") %>%
      expect_doppelganger(snap_name(plot))
  })
})


# Single predictor, on axis, categorical ------------------------------------------------------

test_that("it plots 1 predictor (on axis, categorical) models as lines at means, outcome on Y", {
  testthat::skip_if(Sys.getenv("CI") == "true", "Skipping these tests on GitHub Actions.")

  snap_name <- function(plot_name, suffix = "") {
    glue("[{plot_name}] cond. mod., y on Y{suffix}")
  }

  plot_args <- list(gformula = later_anxiety ~ condition, color = ~condition, data = er)
  plot_types <- c("gf_point", "gf_boxplot", "gf_violin")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er), color = "brown") %>%
      expect_doppelganger(snap_name(plot))
  })
})

test_that("it plots 1 predictor (on axis, categorical) models as lines at means, outcome on X", {
  snap_name <- function(plot_name, suffix = "") {
    glue("[{plot_name}] cond. mod., y on X{suffix}")
  }

  plot_args <- list(gformula = condition ~ later_anxiety, color = ~condition, data = er)
  plot_types <- c("gf_point")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er), color = "brown") %>%
      expect_doppelganger(snap_name(plot))
  })
})


# Single predictor, on aesthetic, categorical -------------------------------------------------

test_that("it plots 1 predictor (on aesthetic, cat.) models as lines at means, outcome on Y", {
  testthat::skip_if(Sys.getenv("CI") == "true", "Skipping these tests on GitHub Actions.")

  snap_name <- function(plot_name, suffix = "") {
    glue("[{plot_name}] cond. mod., y on Y, pred. on color")
  }

  # plots where both axes are specified
  plot_args <- list(gformula = later_anxiety ~ provider, color = ~condition, data = er)
  plot_types <- c("gf_point", "gf_boxplot", "gf_violin")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })

  # plot where one axis is calculated
  plot_args <- list(gformula = ~later_anxiety, color = ~condition, data = er)
  plot_types <- c("gf_rugy")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })
})

test_that("it plots 1 predictor (on aesthetic, cat.) models as lines at means, outcome on X", {
  testthat::skip_if(Sys.getenv("CI") == "true", "Skipping these tests on GitHub Actions.")

  snap_name <- function(plot_name, suffix = "") {
    glue("[{plot_name}] cond. mod., y on X, pred. on color")
  }

  # plots where both axes are specified
  plot_args <- list(gformula = provider ~ later_anxiety, color = ~condition, data = er)
  plot_types <- c("gf_point", "gf_boxplot", "gf_violin")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })

  # plots where one axis is calculated
  plot_args <- list(gformula = ~later_anxiety, color = ~condition, data = er)
  plot_types <- c("gf_histogram", "gf_dhistogram", "gf_rug", "gf_rugx")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })
})


# Single predictor, on facet, categorical -----------------------------------------------------

test_that("it plots 1 predictor (on facet, compact cat.) models as lines at means, outcome on Y", {
  testthat::skip_if(Sys.getenv("CI") == "true", "Skipping these tests on GitHub Actions.")

  snap_name <- function(plot_name, suffix = "") {
    glue("[{plot_name}] cond. mod., y on Y, pred. on facet")
  }

  # plots where both axes are specified
  plot_args <- list(gformula = later_anxiety ~ provider | condition, data = er)
  plot_types <- c("gf_point", "gf_boxplot", "gf_violin")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })

  # alternative specification
  plot_args <- list(gformula = later_anxiety ~ provider, data = er)
  plot_types <- c("gf_point", "gf_boxplot", "gf_violin")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_facet_wrap(~condition) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })

  # plots where one axis is calculated
  # skip "gf_histogramh", "gf_dhistogramh" funs because their related stat funs can't be found
  plot_args <- list(gformula = ~ later_anxiety | condition, data = er)
  plot_types <- c("gf_rugy")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })
})

test_that("it plots 1 predictor (on facet, compact cat.) models as lines at means, outcome on X", {
  testthat::skip_if(Sys.getenv("CI") == "true", "Skipping these tests on GitHub Actions.")

  snap_name <- function(plot_name, suffix = "") {
    glue("[{plot_name}] cond. mod., y on X, pred. on facet")
  }

  # plots where both axes are specified
  plot_args <- list(gformula = provider ~ later_anxiety | condition, data = er)
  plot_types <- c("gf_point", "gf_boxplot", "gf_violin")
  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })

  # plots where one axis is calculated
  plot_args <- list(gformula = ~ later_anxiety | condition, data = er)
  plot_types <- c("gf_histogram", "gf_dhistogram", "gf_rug", "gf_rugx")

  purrr::walk(plot_types, function(plot) {
    do.call(plot, plot_args) %>%
      gf_model(lm(later_anxiety ~ condition, data = er)) %>%
      expect_doppelganger(snap_name(plot))
  })
})


# Single predictor, on axis, continuous -------------------------------------------------------

test_that("it plots 1 predictor (on axis, cont.) models as a fit line", {
  gf_point(later_anxiety ~ base_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety, data = er)) %>%
    expect_doppelganger("[gf_point] anx. mod., y on Y")

  gf_point(base_anxiety ~ later_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety, data = er)) %>%
    expect_doppelganger("[gf_point] anx. mod., y on X")
})


# Single predictor, on aesthetic, continuous --------------------------------------------------

test_that("it splits continuous aesthetic predictors at -+1 SD and mean", {
  gf_point(later_anxiety ~ condition, color = ~base_anxiety, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety, data = er)) %>%
    expect_doppelganger("[gf_point] anx. mod., pred. on color, y on Y")

  gf_point(condition ~ later_anxiety, color = ~base_anxiety, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety, data = er)) %>%
    expect_doppelganger("[gf_point] anx. mod., pred. on color, y on X")
})


# Two predictors, on axis and aesthetic -------------------------------------------------------

test_that("it plots main effects models (cat. + cat.)", {
  gf_point(later_anxiety ~ provider, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ provider + condition, data = er)) %>%
    expect_doppelganger("[gf_point] floating 'parallel' hashes in two colors")
})

test_that("it plots main effects models (quant. + cat.)", {
  gf_point(later_anxiety ~ base_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety + condition, data = er)) %>%
    expect_doppelganger("[gf_point] parallel lines in 2 colors")
})

test_that("it plots main effects models (cat. + quant.)", {
  gf_point(later_anxiety ~ condition, color = ~base_anxiety, data = er) %>%
    gf_model(lm(later_anxiety ~ condition + base_anxiety, data = er)) %>%
    expect_doppelganger("[gf_point] parallel hashes in 3 colors (M, +-SD)")
})

test_that("it plots main effect models (quant. + quant.)", {
  gf_point(later_anxiety ~ base_anxiety, color = ~base_depression, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety + base_depression, data = er)) %>%
    expect_doppelganger("[gf_point] parallel lines in 3 colors (M, +-SD)")
})

test_that("it plots interactive models (cat. * cat.)", {
  gf_point(later_anxiety ~ provider, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ provider * condition, data = er)) %>%
    expect_doppelganger("[gf_point] diverging hashes in 2 colors")
})

test_that("it plots interactive models (quant. * cat.)", {
  gf_point(later_anxiety ~ base_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety * condition, data = er)) %>%
    expect_doppelganger("[gf_point] diverging lines in 2 colors")

  gf_point(base_anxiety ~ later_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety * condition, data = er)) %>%
    expect_doppelganger("[gf_point] diverging lines in 2 colors, flipped")
})

test_that("it plots interactive models (cat. * quant.)", {
  gf_point(later_anxiety ~ condition, color = ~base_anxiety, data = er) %>%
    gf_model(lm(later_anxiety ~ condition * base_anxiety, data = er)) %>%
    expect_doppelganger("[gf_point] non-parallel hashes in 3 colors (M, +-SD)")
})

test_that("it plots interactive models (quant. * quant.)", {
  gf_point(later_anxiety ~ base_anxiety, color = ~base_depression, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety * base_depression, data = er)) %>%
    expect_doppelganger("[gf_point] crossing lines in 2 colors")
})


# Two predictors, on axis and facet -----------------------------------------------------------

test_that("it plots main effect models across facets (cat. + cat.)", {
  gf_point(later_anxiety ~ provider | condition, data = er) %>%
    gf_model(lm(later_anxiety ~ provider + condition, data = er)) %>%
    expect_doppelganger("[gf_point] hashes at an offset across facets")
})

test_that("it plots main effect models across facets (quant. + cat.)", {
  gf_point(later_anxiety ~ base_anxiety | condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety + condition, data = er)) %>%
    expect_doppelganger("[gf_point] parallel lines in different facets")
})

test_that("it plots interactive models across facets (cat. * cat.)", {
  gf_point(later_anxiety ~ provider | condition, data = er) %>%
    gf_model(lm(later_anxiety ~ provider * condition, data = er)) %>%
    expect_doppelganger("[gf_point] hash patterns across facets")
})

test_that("it plots interactive models across facets (quant. * cat.)", {
  gf_point(later_anxiety ~ base_anxiety | condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety * condition, data = er)) %>%
    expect_doppelganger("[gf_point] diverging lines in facets")

  gf_point(base_anxiety ~ later_anxiety | condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety + condition, data = er)) %>%
    expect_doppelganger("[gf_point] diverging lines in facets, flipped")
})

# faceting on a quantitative variable isn't advisable -- maybe just show a warning for this?
# it plots main effect models across facets (cat. + quant.)
# it plots main effect models across facets (quant. + quant.)
# it plots interactive models across facets (cat. * quant.)
# it plots interactive models across facets (quant. * quant.)


# Mappings ------------------------------------------------------------------------------------

test_that("it respects static aesthetic choices", {
  gf_point(later_anxiety ~ base_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety, data = er), color = "blue") %>%
    expect_doppelganger("[gf_point] model line is blue")
})

test_that("it un-maps dynamic aesthetics from underlying layers that are not in the model", {
  gf_point(later_anxiety ~ base_anxiety, color = ~condition, shape = ~provider, data = er) %>%
    gf_model(lm(later_anxiety ~ base_anxiety, data = er)) %>%
    expect_doppelganger("[gf_point] anx. mod., y on Y, with color & shape")
})

test_that("it will translate color arguments if applicable (e.g. fill to color)", {
  gf_boxplot(later_anxiety ~ provider, fill = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ condition, data = er)) %>%
    expect_doppelganger("[gf_point] cond. mod., y on Y, with color")
})

test_that("it can use aesthetics other than color... just checking", {
  gf_point(later_anxiety ~ base_anxiety, shape = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ condition, data = er)) %>%
    expect_doppelganger("[gf_point] cond. mod., y on Y, pred. on shape")
})

test_that("it allows mapping new aesthetics", {
  gf_point(later_anxiety ~ base_anxiety, color = ~condition, data = er) %>%
    gf_model(lm(later_anxiety ~ condition, data = er), linetype = ~condition) %>%
    expect_doppelganger("[gf_point] cond. mod., y on Y, pred. on color, linetype")
})



# Alternate specification ---------------------------------------------------------------------

test_that("you can pass it a formula instead of an `lm()` object", {
  gf_point(later_anxiety ~ base_anxiety, color = ~condition, data = er) %>%
    gf_model(later_anxiety ~ condition) %>%
    expect_doppelganger("match to lm() version")
})


# Other tests ---------------------------------------------------------------------------------

test_that("it treats boolean and character predictors like factors", {
  new_er <- er %>%
    mutate(base_anxiety_high = base_anxiety > 5)

  gf_point(later_anxiety ~ base_anxiety_high, data = new_er) %>%
    gf_model(later_anxiety ~ base_anxiety_high) %>%
    expect_doppelganger("[gf_point] hashes TRUE higher than FALSE")
})