tests/testthat/test-morph-pixel.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Tests for pixel morphing functions (morph_pixel.R)
# ==============================================================================

# Skip all tests if magick is not available
skip_if_not_installed("magick")

# Helper to get test images
get_test_images <- function() {
  imgA <- system.file("extdata/icons/circleA_40.png", package = "couplr")
  imgB <- system.file("extdata/icons/circleB_40.png", package = "couplr")
  if (!nzchar(imgA) || !nzchar(imgB)) {
    skip("Test images not found")
  }
  list(A = imgA, B = imgB)
}

# ------------------------------------------------------------------------------
# Input validation tests for pixel_morph_animate
# ------------------------------------------------------------------------------

test_that("pixel_morph_animate validates upscale parameter", {
  imgs <- get_test_images()

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, upscale = "invalid", show = FALSE),
    "upscale must be a single numeric"
  )

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, upscale = NA, show = FALSE),
    "upscale must be a single numeric"
  )

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, upscale = c(1, 2), show = FALSE),
    "upscale must be a single numeric"
  )
})

test_that("pixel_morph_animate validates n_frames parameter", {
  imgs <- get_test_images()

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, n_frames = "invalid", show = FALSE),
    "n_frames must be a single numeric"
  )

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, n_frames = NA, show = FALSE),
    "n_frames must be a single numeric"
  )
})

test_that("pixel_morph_animate validates alpha and beta parameters", {
  imgs <- get_test_images()

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, alpha = -1, show = FALSE),
    "alpha must be a single non-negative"
  )

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, beta = -1, show = FALSE),
    "beta must be a single non-negative"
  )

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, alpha = 0, beta = 0, show = FALSE),
    "alpha and beta cannot both be zero"
  )
})

test_that("pixel_morph_animate validates patch_size parameter", {
  imgs <- get_test_images()

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, patch_size = "invalid", show = FALSE),
    "patch_size must be a single numeric"
  )

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, patch_size = 0, show = FALSE),
    "patch_size must be at least 1"
  )
})

test_that("pixel_morph_animate validates downscale_steps parameter", {
  imgs <- get_test_images()

  expect_error(
    pixel_morph_animate(imgs$A, imgs$B, downscale_steps = -1, show = FALSE),
    "downscale_steps must be non-negative"
  )
})

# ------------------------------------------------------------------------------
# Input validation tests for pixel_morph
# ------------------------------------------------------------------------------

test_that("pixel_morph validates upscale parameter", {
  imgs <- get_test_images()

  expect_error(
    pixel_morph(imgs$A, imgs$B, upscale = "invalid", show = FALSE),
    "upscale must be a single numeric"
  )
})

test_that("pixel_morph validates alpha/beta parameters", {
  imgs <- get_test_images()

  expect_error(
    pixel_morph(imgs$A, imgs$B, alpha = 0, beta = 0, show = FALSE),
    "alpha and beta cannot both be zero"
  )
})

# ------------------------------------------------------------------------------
# Functional tests for pixel_morph
# ------------------------------------------------------------------------------

test_that("pixel_morph works with exact mode", {
  imgs <- get_test_images()

  result <- pixel_morph(imgs$A, imgs$B, mode = "exact", n_frames = 2, show = FALSE)

  expect_s3_class(result, "magick-image")
  info <- magick::image_info(result)
  expect_equal(info$width, 40)
  expect_equal(info$height, 40)
})

test_that("pixel_morph works with color_walk mode", {
  imgs <- get_test_images()

  result <- pixel_morph(imgs$A, imgs$B, mode = "color_walk", n_frames = 2, show = FALSE)

  expect_s3_class(result, "magick-image")
})

test_that("pixel_morph works with recursive mode", {
  imgs <- get_test_images()

  result <- pixel_morph(imgs$A, imgs$B, mode = "recursive", n_frames = 2, show = FALSE)

  expect_s3_class(result, "magick-image")
})

test_that("pixel_morph works with patch_size > 1", {
  imgs <- get_test_images()

  result <- pixel_morph(imgs$A, imgs$B, mode = "exact", patch_size = 3,
                        n_frames = 2, show = FALSE)

  expect_s3_class(result, "magick-image")
})

test_that("pixel_morph handles upscale parameter", {
  imgs <- get_test_images()

  result <- pixel_morph(imgs$A, imgs$B, mode = "exact", n_frames = 2,
                        upscale = 2, show = FALSE)

  expect_s3_class(result, "magick-image")
  info <- magick::image_info(result)
  expect_equal(info$width, 80)
  expect_equal(info$height, 80)
})

test_that("pixel_morph handles fractional upscale", {
  imgs <- get_test_images()

  result <- pixel_morph(imgs$A, imgs$B, mode = "exact", n_frames = 2,
                        upscale = 1.5, show = FALSE)

  expect_s3_class(result, "magick-image")
})

# ------------------------------------------------------------------------------
# Functional tests for pixel_morph_animate
# ------------------------------------------------------------------------------

test_that("pixel_morph_animate creates animation with correct number of frames", {
  imgs <- get_test_images()

  result <- pixel_morph_animate(imgs$A, imgs$B, n_frames = 4, show = FALSE)

  expect_type(result, "list")
  expect_s3_class(result$animation, "magick-image")
  expect_equal(result$n_pixels, 40 * 40)
  expect_equal(result$width, 40)
  expect_equal(result$height, 40)
})

test_that("pixel_morph_animate returns correct assignment vector", {
  imgs <- get_test_images()

  result <- pixel_morph_animate(imgs$A, imgs$B, n_frames = 2, show = FALSE)

  expect_type(result$assignment, "integer")
  expect_equal(length(result$assignment), 40 * 40)
  # Assignment should be 1-based (R convention)
  expect_true(all(result$assignment >= 1))
  expect_true(all(result$assignment <= 40 * 40))
})

test_that("pixel_morph_animate works with all modes", {
  imgs <- get_test_images()

  for (mode in c("exact", "color_walk", "recursive")) {
    result <- pixel_morph_animate(imgs$A, imgs$B, mode = mode,
                                  n_frames = 2, show = FALSE)
    expect_type(result, "list")
    expect_equal(result$mode, mode)
  }
})

test_that("pixel_morph_animate handles downscale_steps", {
  imgs <- get_test_images()

  result <- suppressWarnings(pixel_morph_animate(imgs$A, imgs$B, downscale_steps = 1,
                                n_frames = 2, show = FALSE))

  expect_type(result, "list")
  # Original dimensions preserved in output
  expect_equal(result$width, 40)
  expect_equal(result$height, 40)
})

test_that("pixel_morph_animate can save to file", {
  imgs <- get_test_images()
  outfile <- tempfile(fileext = ".gif")

  result <- pixel_morph_animate(imgs$A, imgs$B, n_frames = 2,
                                outfile = outfile, show = FALSE)

  expect_true(file.exists(outfile))
  unlink(outfile)
})

test_that("pixel_morph_animate handles webp format", {
  imgs <- get_test_images()
  outfile <- tempfile(fileext = ".webp")

  result <- pixel_morph_animate(imgs$A, imgs$B, n_frames = 2,
                                format = "webp", outfile = outfile, show = FALSE)

  expect_true(file.exists(outfile))
  unlink(outfile)
})

# ------------------------------------------------------------------------------
# Edge case tests
# ------------------------------------------------------------------------------

test_that("pixel_morph handles images of different sizes", {
  imgs <- get_test_images()

  # Load and resize one image
  A <- magick::image_read(imgs$A)
  B <- magick::image_read(imgs$B)
  B_resized <- magick::image_resize(B, "30x30!")

  # Should auto-resize B to match A
  result <- pixel_morph(A, B_resized, mode = "exact", n_frames = 2, show = FALSE)

  expect_s3_class(result, "magick-image")
  info <- magick::image_info(result)
  expect_equal(info$width, 40)
  expect_equal(info$height, 40)
})

test_that("pixel_morph_animate warns on large images for exact mode", {
  skip_on_cran()  # Skip on CRAN due to resource constraints
  imgs <- get_test_images()

  # This should warn about large image
  # We can't easily test this without creating a large image
  # Just ensure the code path exists
  expect_true(TRUE)
})

test_that("pixel_morph warns on negative upscale (sets to 1)", {
  imgs <- get_test_images()

  expect_warning(
    pixel_morph(imgs$A, imgs$B, upscale = -1, n_frames = 2, show = FALSE),
    "upscale must be positive"
  )
})

test_that("pixel_morph_animate warns on small n_frames (sets to 2)", {
  imgs <- get_test_images()

  expect_warning(
    pixel_morph_animate(imgs$A, imgs$B, n_frames = 1, show = FALSE),
    "n_frames must be at least 2"
  )
})