tests/testthat/test-plot.R

In wal: Read and Write 'wal' Bitmap Image Files and Other 'Quake' Assets

# Tests for the plotting functions (plot.wal, plotwal.mipmap, plotwal.rawdata).
#
# These tests capture the OBSERVABLE behavior of the plotting functions so that
# the internal rendering implementation can be swapped without breaking
# anything. They must not depend on which rendering backend is used.
#
# The last test ('The base R raster recipe...') pins down the exact base-R
# recipe (as.raster + aperm + /255) used by the rendering functions, including
# the expected color strings and the orientation (first scanline = top row of
# the raster).


# Helper: evaluate an expression on a null PDF device, to avoid writing
# Rplots.pdf files and to make plotting hermetic.
plot.on.null.device <- function(expr) {
  grDevices::pdf(NULL);
  on.exit(grDevices::dev.off());
  force(expr);
}


testthat::test_that("plot(wal) plots a wal instance with image data without error.", {
  walf = system.file("extdata", "bricks.wal", package = "wal", mustWork = TRUE);
  wal = suppressWarnings(wal::read.wal(walf));

  testthat::expect_false(is.null(wal$image));

  plot.on.null.device({
    testthat::expect_no_error(plot(wal));
  });
})


testthat::test_that("plot(wal) on a wal without image uses grayscale preview and warns.", {
  walf = system.file("extdata", "bricks.wal", package = "wal", mustWork = TRUE);
  wal = suppressWarnings(wal::read.wal(walf, apply_palette = NULL)); # no image data in the wal instance.

  testthat::expect_true(is.null(wal$image));

  plot.on.null.device({
    testthat::expect_warning(plot(wal), "grayscale preview");
  });
})


testthat::test_that("plotwal.mipmap plots all mip levels without error.", {
  walf = system.file("extdata", "bricks.wal", package = "wal", mustWork = TRUE);
  wal = suppressWarnings(wal::read.wal(walf));

  plot.on.null.device({
    for(mip in 0:3) {
      testthat::expect_no_error(plotwal.mipmap(wal, apply_palette = wal::pal_q2(), mip_level = mip));
    }
    testthat::expect_no_error(plotwal.mipmap(wal, apply_palette = wal::pal_q1(), mip_level = 0));
  });
})


testthat::test_that("plotwal.mipmap errors on invalid mip level.", {
  walf = system.file("extdata", "bricks.wal", package = "wal", mustWork = TRUE);
  wal = suppressWarnings(wal::read.wal(walf));

  plot.on.null.device({
    testthat::expect_error(plotwal.mipmap(wal, apply_palette = wal::pal_q2(), mip_level = 4), "mip_level");
    testthat::expect_error(plotwal.mipmap(wal, apply_palette = wal::pal_q2(), mip_level = -1), "mip_level");
  });
})


testthat::test_that("plotwal.mipmap with NULL palette warns and uses grayscale.", {
  walf = system.file("extdata", "bricks.wal", package = "wal", mustWork = TRUE);
  wal = suppressWarnings(wal::read.wal(walf));

  plot.on.null.device({
    testthat::expect_warning(plotwal.mipmap(wal, apply_palette = NULL, mip_level = 0), "grayscale");
  });
})


testthat::test_that("plotwal.rawdata plots valid raw pixel data without error.", {
  walf = system.file("extdata", "bricks.wal", package = "wal", mustWork = TRUE);
  wal = suppressWarnings(wal::read.wal(walf));

  plot.on.null.device({
    testthat::expect_no_error(plotwal.rawdata(wal$raw_data, wal$header$width, wal$header$height));
    testthat::expect_no_error(plotwal.rawdata(wal$raw_data, wal$header$width, wal$header$height, apply_palette = wal::pal_q1()));
  });
})


testthat::test_that("plotwal.rawdata errors when raw data is too small for the image size.", {
  plot.on.null.device({
    testthat::expect_error(plotwal.rawdata(c(1, 2, 3), 100, 100), "too small");
  });
})


testthat::test_that("plotwal.rawdata with NULL palette warns and uses grayscale.", {
  walf = system.file("extdata", "bricks.wal", package = "wal", mustWork = TRUE);
  wal = suppressWarnings(wal::read.wal(walf));

  plot.on.null.device({
    testthat::expect_warning(plotwal.rawdata(wal$raw_data, wal$header$width, wal$header$height, apply_palette = NULL), "grayscale");
  });
})


testthat::test_that("The base R raster recipe produces correct colors and orientation.", {
  # Small image, width 2, height 3, RGB values in range 0..255.
  w = 2L; h = 3L;
  img = array(0L, c(w, h, 3));
  img[1,1,] = c(255L, 0L, 0L);     # x=1, y=1 -> red
  img[2,1,] = c(0L, 255L, 0L);     # x=2, y=1 -> green
  img[1,2,] = c(0L, 0L, 255L);     # x=1, y=2 -> blue
  img[2,2,] = c(255L, 255L, 0L);   # x=2, y=2 -> yellow
  img[1,3,] = c(255L, 0L, 255L);   # x=1, y=3 -> magenta
  img[2,3,] = c(0L, 255L, 255L);   # x=2, y=3 -> cyan

  # The recipe used by the plotting functions to display an RGB array:
  r = grDevices::as.raster(aperm(img / 255.0, c(2, 1, 3)));

  # Result is a height x width matrix of color strings.
  testthat::expect_equal(dim(r), c(h, w));

  # Color correctness. (Elements are 'raster'-classed; compare as plain strings.)
  testthat::expect_identical(as.character(r[1,1]), "#FF0000");  # top-left
  testthat::expect_identical(as.character(r[1,2]), "#00FF00");  # top-right
  testthat::expect_identical(as.character(r[2,1]), "#0000FF");
  testthat::expect_identical(as.character(r[3,1]), "#FF00FF");  # bottom-left (y=3)
  testthat::expect_identical(as.character(r[3,2]), "#00FFFF");  # bottom-right

  # Orientation: first scanline of the image (y=1) must be the first row of the
  # raster, i.e., it is displayed at the top.
  testthat::expect_identical(as.character(r[1,1]), grDevices::rgb(1, 0, 0));
})


testthat::test_that("render.rgb.array renders a solid color image to a device correctly (integration).", {
  # A solid red image; any point inside the plotted image must be red.
  img = array(0L, c(8, 8, 3));
  img[,,1] = 255L;
  img[,,2] = 0L;
  img[,,3] = 0L;

  pngf = tempfile(fileext = ".png");
  grDevices::png(pngf, width = 200, height = 200, units = "px", res = 1);
  on.exit(if(grDevices::dev.cur() > 1L) grDevices::dev.off());
  wal:::render.rgb.array(img);
  grDevices::dev.off();

  p = png::readPNG(pngf); # dims: height x width x channels
  # Sample a point well inside the plot region (device center).
  center = p[nrow(p) %/% 2L, ncol(p) %/% 2L, 1:3];
  testthat::expect_gt(center[1], 0.9); # red
  testthat::expect_lt(center[2], 0.1); # no green
  testthat::expect_lt(center[3], 0.1); # no blue
})