tests/testthat/test-plots.R

In volker: High-Level Functions for Tabulating, Charting and Reporting Survey Data

#
# Test plot features
#

library(testthat)
library(volker)
library(dplyr)

# --- Setup ------------------------------------------------------------------

# If vdiffr is not installed, skip all visual tests
if (requireNamespace("vdiffr", quietly = TRUE) && utils::packageVersion('testthat') >= '3.0.3') {
  library(vdiffr)
  expect_doppelganger <- vdiffr::expect_doppelganger
} else {
  expect_doppelganger <- function(...) skip("vdiffr is not installed.")
}

# Only run plot tests if explicitly enabled
# because they will fail on different machines due
# to different rendering engines.
#
# Enable:
# Sys.setenv("R_LOCALTESTS" = "1")
# Disable:
# Sys.unsetenv("R_LOCALTESTS")


# Load the sample data
data <- volker::chatgpt

test_that("Empty plots are empty", {
  test_data <- tibble(var1=c(NA))

  plot_counts(test_data, var1) |>
    expect_error("Check your data: Are they empty?")

})


if (Sys.getenv("R_LOCALTESTS") == "1") {

  ggplot2::theme_set(ggplot2::theme_test())
  #ggplot2::theme_set(volker::theme_vlkr())

  test_that("Categorical plots render as expected", {

    expect_doppelganger("plot_counts_one", {
      data |> plot_counts(adopter)
    })

    expect_doppelganger("plot_counts_one with binary data", {
      data |> mutate(adopter = adopter == "I try new offers immediately") |> plot_counts(adopter)
    })

    expect_doppelganger("plot_counts_one with focus category", {
      data |> plot_counts(adopter, category = "I try new offers immediately")
    })

    expect_doppelganger("plot_counts_one_grouped", {
      plot_counts(data, sd_gender, adopter)
    })

    expect_doppelganger("plot_counts_one_grouped with rowsprops", {
      data |> plot_counts(adopter, sd_gender, prop = "rows", numbers = "p")
    })

    expect_doppelganger("plot_counts_one_grouped with cols props", {
      plot_counts(data, adopter, sd_gender, prop = "cols", numbers = "p", ordered = -1)
    })

    expect_doppelganger("plot_counts_one_grouped_reversed", {
      data |> mutate(adopter = factor(adopter, levels = rev(levels(adopter)))) |>
        plot_counts(adopter, sd_gender, prop = "cols")
    })

    expect_doppelganger("plot_counts_one_cor", {
      plot_counts(data, adopter, sd_age, metric = TRUE)
    })

    expect_doppelganger("plot_counts_one_cor with rows props", {
      plot_counts(data, adopter, sd_age, metric = TRUE, prop = "rows")
    })


    expect_doppelganger("plot_counts_items", {
      plot_counts(data, starts_with("cg_adoption_"), numbers = "p")
    })

    expect_doppelganger("plot_counts_items with binary data", {
      data |> mutate(across(starts_with("cg_adoption_advantage"), \(x) x > 3)) |>
        plot_counts(starts_with("cg_adoption_advantage"))
    })

    expect_doppelganger("plot_counts_items_grouped", {
      plot_counts(
        data, starts_with("cg_adoption_"), adopter,
        category = c("agree", "strongly agree")
      )
    })

    # TODO: Fix theming of tile stroke width
    # expect_doppelganger("plot_counts_items_grouped_items", {
    #   plot_counts(
    #     data, starts_with("cg_adoption_"), starts_with("cg_adoption_")
    #   )
    # })

    expect_doppelganger("plot_counts_items_cor", {
      plot_counts(
        data, starts_with("cg_adoption_"), sd_age, metric = TRUE,
        category = c(4, 5)
      )
    })

  })

  test_that("Metric distribution plots render as expected", {

    expect_doppelganger("plot_metrics_one", {
      plot_metrics(data, sd_age)
    })

    expect_doppelganger("plot_metrics_one with box", {
      plot_metrics(data, sd_age, box = TRUE)
    })

    expect_doppelganger("plot_metrics_one with ci", {
      plot_metrics(data, sd_age, ci = TRUE)
    })

    expect_doppelganger("plot_metrics_one_grouped", {
      plot_metrics(data, sd_age, sd_gender)
    })

    expect_doppelganger("plot_metrics_one_cor", {
      plot_metrics(data, sd_age, use_work, metric = TRUE)
    })

    expect_doppelganger("plot_metrics_one_cor with log scale", {
      plot_metrics(data, sd_age, use_work, metric = TRUE, log = TRUE)
    })

    expect_doppelganger("plot_metrics_one_cor without title", {
      plot_metrics(data, sd_age, use_work, metric = TRUE, title = FALSE)
    })

    expect_doppelganger("plot_metrics_items", {
      plot_metrics(data, starts_with("cg_adoption_"))
    })

    expect_doppelganger("plot_metrics_items_grouped", {
      plot_metrics(data, starts_with("cg_adoption_"), sd_gender)
    })

    expect_doppelganger("plot_metrics_items_cor with pearson's r", {
      plot_metrics(data, starts_with("use_"), sd_age, metric = TRUE)
    })

    expect_doppelganger("plot_metrics_items_cor with spearman's rho", {
      plot_metrics(data, starts_with("use_"), sd_age, metric = TRUE, method = "spearman")
    })

    # TODO: Fix theming of tile stroke width
    # expect_doppelganger("plot_metrics_items_cor_items", {
    #   plot_metrics(data, starts_with("cg_adoption_adv"), starts_with("use_"), metric = TRUE)
    # })

    # TODO: Fix theming of tile stroke width
    # expect_doppelganger("plot_metrics_items_cor_items with numbers", {
    #   plot_metrics(
    #     data, starts_with("cg_adoption_adv"),
    #     starts_with("use_"),
    #     metric = TRUE,
    #     numbers = TRUE
    #   )
    # })
  })

  test_that("Index plots render as expected", {

    expect_doppelganger("index_distribution_grouped", {
      data %>%
        add_index(starts_with("cg_adoption_social_")) %>%
        add_index(starts_with("cg_adoption_fearofuse_")) %>%
        add_index(starts_with("cg_adoption_advantage_")) %>%
        labs_apply(tribble(
          ~item_name, ~item_label,
          "idx_cg_adoption_social", "ChatGPT-Erwartung: Social",
          "idx_cg_adoption_fearofuse", "ChatGPT-Erwartung: Fear of Use",
          "idx_cg_adoption_advantage", "ChatGPT-Erwartung: Advantage"
        )) %>%
        plot_metrics(starts_with("idx_cg_adoption"), adopter)
    })

  })

  test_that("New labels render as expected", {

    expect_doppelganger("apply_value_labels_plot", {
      data %>%
        filter(sd_gender != "diverse") %>%
        labs_apply(
          cols = sd_gender,
          values = list(
            "female" = "Weiblich",
            "male" = "Maennlich"
          )
        ) %>%
        plot_metrics(sd_age, sd_gender)
    })
  })


} else {
  skip("R_LOCALTESTS not set; skipping visual tests.")
}