tests/testthat/test-pixel-morph.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# Test suite for pixel morphing functionality

test_that("pixel_morph helper functions work", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")

  H <- 8; W <- 8

  # Create a simple test array
  test_arr <- array(0L, dim = c(H, W, 3))
  test_arr[4, 4, 1] <- 255L  # Red pixel

  # Planar conversion
  planar <- .to_planar_rgb(test_arr)
  expect_length(planar, H * W * 3)

  # The exact index depends on your planar layout; round-trip instead:
  arr_back <- .from_planar_rgb(planar, H, W)
  expect_equal(dim(arr_back), c(H, W, 3))
  expect_equal(arr_back[4, 4, 1], 255L)

  # Clamp
  test_vals <- c(-10, 0, 128, 255, 300)
  clamped <- .clamp_rgb(test_vals)
  expect_equal(clamped, c(0L, 0L, 128L, 255L, 255L))
})

test_that("pixel cost matrix computation works", {
  skip_if_not(exists("compute_pixel_cost_cpp"))

  H <- 4; W <- 4; N <- H * W
  pixelsA <- numeric(N * 3)
  pixelsB <- numeric(N * 3)

  # One red pixel in A at linear index 5 (row-major)
  pixelsA[5] <- 255
  # One blue pixel in B at linear index 11
  pixelsB[11 + 2*N] <- 255

  cost <- compute_pixel_cost_cpp(pixelsA, pixelsB, H, W, 1, 1)
  expect_equal(dim(cost), c(N, N))
  expect_true(all(is.finite(cost)))
  expect_true(all(cost >= 0))
})

test_that("pixel_morph_animate creates animation with small test images (exact)", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"), message = "C++ morphing function not available")

  H <- 8; W <- 8
  imgA <- array(0, c(H, W, 3))
  imgA[4:5, 2:3, 1] <- 255  # red block (left)

  imgB <- array(0, c(H, W, 3))
  imgB[4:5, 6:7, 3] <- 255  # blue block (right)

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  tmpOut <- withr::local_tempfile(fileext = ".gif")
  png::writePNG(imgA/255, tmpA)
  png::writePNG(imgB/255, tmpB)

  result <- pixel_morph_animate(
    imgA = tmpA, imgB = tmpB,
    alpha = 1, beta = 0,
    n_frames = 4L, fps = 10L,
    outfile = tmpOut, show = FALSE,
    mode = "exact"
  )

  expect_type(result, "list")
  expect_equal(result$n_pixels, H * W)
  expect_equal(result$mode, "exact")
  expect_true(file.exists(tmpOut))
  expect_gt(file.size(tmpOut), 0)
})

test_that("pixel_morph static function returns final frame only", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))

  H <- 8; W <- 8
  imgA <- array(0, c(H, W, 3))
  imgA[4:5, 2:3, 1] <- 255  # red block

  imgB <- array(0, c(H, W, 3))
  imgB[4:5, 6:7, 3] <- 255  # blue block

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  png::writePNG(imgA/255, tmpA)
  png::writePNG(imgB/255, tmpB)

  # pixel_morph returns magick image, not list
  result <- pixel_morph(
    imgA = tmpA, imgB = tmpB,
    alpha = 1, beta = 0,
    show = FALSE,
    mode = "exact"
  )

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

test_that("pixel_morph_animate color_walk mode works with varied colors", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))
  skip_if_not(exists("color_palette_info_cpp"))

  H <- 8; W <- 8
  set.seed(123)
  imgA <- array(runif(H * W * 3), c(H, W, 3))
  imgB <- array(runif(H * W * 3), c(H, W, 3))

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  tmpOut <- withr::local_tempfile(fileext = ".gif")
  png::writePNG(imgA, tmpA)
  png::writePNG(imgB, tmpB)

  result <- pixel_morph_animate(
    imgA = tmpA, imgB = tmpB,
    n_frames = 4L, fps = 10L,
    outfile = tmpOut, show = FALSE,
    mode = "color_walk",
    quantize_bits = 6L
  )

  expect_type(result, "list")
  expect_equal(result$n_pixels, H * W)
  expect_true(file.exists(tmpOut))
  expect_equal(result$mode, "color_walk")
})

test_that("pixel_morph_animate exact mode enforces size limit with warning", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))

  # Create an image larger than the 4096 pixel recommended limit
  H <- 80; W <- 80  # 6400 pixels > 4096
  imgLarge <- array(runif(H * W * 3), c(H, W, 3))
  
  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  tmpOut <- withr::local_tempfile(fileext = ".gif")
  png::writePNG(imgLarge, tmpA)
  png::writePNG(imgLarge, tmpB)

  # Should warn but still work
  expect_warning(
    pixel_morph_animate(
      imgA = tmpA, imgB = tmpB,
      n_frames = 2L, fps = 5L,
      outfile = tmpOut, show = FALSE,
      mode = "exact",
      patch_size = 1L
    ),
    regexp = "Image is large for 'exact' global LAP"
  )
  
  expect_true(file.exists(tmpOut))
})

test_that("pixel_morph exact mode runs with flat colors", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))
  skip_if_not(exists("compute_pixel_cost_cpp"))

  H <- 8; W <- 8
  imgA <- array(0.5, c(H, W, 3))
  imgB <- array(0.5, c(H, W, 3))

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  png::writePNG(imgA, tmpA)
  png::writePNG(imgB, tmpB)

  result <- pixel_morph(
    imgA = tmpA, imgB = tmpB,
    show = FALSE,
    mode = "exact",
    alpha = 1, beta = 0
  )

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

test_that("pixel_morph handles file-based images", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))

  H <- 8; W <- 8
  img1 <- array(runif(H * W * 3), c(H, W, 3))
  img2 <- array(runif(H * W * 3), c(H, W, 3))

  tmpFile1 <- withr::local_tempfile(fileext = ".png")
  tmpFile2 <- withr::local_tempfile(fileext = ".png")
  png::writePNG(img1, tmpFile1)
  png::writePNG(img2, tmpFile2)

  # We just want to ensure pixel_morph can read file paths and run;
  # use 'exact' mode, which is known to work in the static function.
  result <- pixel_morph(
    imgA = tmpFile1, imgB = tmpFile2,
    show = FALSE,
    mode = "exact"
  )

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

test_that("exact mode with downscaling can handle larger images", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))
  skip_if_not(exists("downscale_image_cpp"))

  # Create image larger than exact limit, but use downscaling
  H <- 200; W <- 200  # 40,000 pixels
  
  imgLarge <- array(runif(H * W * 3), c(H, W, 3))
  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  tmpOut <- withr::local_tempfile(fileext = ".gif")
  png::writePNG(imgLarge, tmpA)
  png::writePNG(imgLarge, tmpB)

  # Expect the non-permutation warning, but keep the result
  expect_warning(
    result <- pixel_morph_animate(
      imgA = tmpA, imgB = tmpB,
      n_frames = 2L, fps = 5L,
      outfile = tmpOut, show = FALSE,
      mode = "exact",
      downscale_steps = 2L  # Solve at 1/4 resolution
    ),
    regexp = "Assignment is not a permutation"
  )
  
  expect_true(file.exists(tmpOut))
  expect_equal(result$mode, "exact")
  expect_gt(file.size(tmpOut), 0)
})


test_that("color_walk uses pure color matching (not spatial)", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))
  skip_if_not(exists("color_palette_info_cpp"))

  H <- 8; W <- 8
  # Create two images with different spatial arrangements of same colors
  imgA <- array(0, c(H, W, 3))
  imgA[2:3, 2:3, 1] <- 255  # red top-left
  imgA[6:7, 6:7, 3] <- 255  # blue bottom-right

  imgB <- array(0, c(H, W, 3))
  imgB[2:3, 6:7, 1] <- 255  # red top-right (moved)
  imgB[6:7, 2:3, 3] <- 255  # blue bottom-left (moved)

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  tmpOut <- withr::local_tempfile(fileext = ".gif")
  png::writePNG(imgA/255, tmpA)
  png::writePNG(imgB/255, tmpB)

  result <- pixel_morph_animate(
    imgA = tmpA, imgB = tmpB,
    n_frames = 4L, fps = 10L,
    outfile = tmpOut, show = FALSE,
    mode = "color_walk",
    quantize_bits = 6L
  )

  # Just check it runs successfully
  expect_type(result, "list")
  expect_equal(result$mode, "color_walk")
  expect_true(file.exists(tmpOut))
  expect_gt(file.size(tmpOut), 0)
})

test_that("permutation warning is issued with downscaling", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))

  H <- 64; W <- 64
  imgA <- array(runif(H * W * 3), c(H, W, 3))
  imgB <- array(runif(H * W * 3), c(H, W, 3))

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  png::writePNG(imgA, tmpA)
  png::writePNG(imgB, tmpB)

  # With downscaling, assignment is likely not a permutation
  expect_warning(
    pixel_morph(
      imgA = tmpA, imgB = tmpB,
      mode = "exact",
      downscale_steps = 2L,  # This creates non-permutation
      show = FALSE
    ),
    regexp = "overlaps.*holes"
  )
})

test_that("no permutation warning without downscaling on small image", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))

  H <- 8; W <- 8  # Small enough for exact mode
  imgA <- array(runif(H * W * 3), c(H, W, 3))
  imgB <- array(runif(H * W * 3), c(H, W, 3))

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  png::writePNG(imgA, tmpA)
  png::writePNG(imgB, tmpB)

  # Without downscaling, exact mode should produce perfect permutation
  expect_silent(
    pixel_morph(
      imgA = tmpA, imgB = tmpB,
      mode = "exact",
      downscale_steps = 0L,
      patch_size = 1L,
      show = FALSE
    )
  )
})

test_that("alpha and beta parameters control matching behavior", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))

  H <- 8; W <- 8
  imgA <- array(runif(H * W * 3), c(H, W, 3))
  imgB <- array(runif(H * W * 3), c(H, W, 3))

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  png::writePNG(imgA, tmpA)
  png::writePNG(imgB, tmpB)

  # Pure color matching
  result_color <- pixel_morph(
    imgA = tmpA, imgB = tmpB,
    mode = "exact",
    alpha = 1, beta = 0,
    show = FALSE
  )
  expect_s3_class(result_color, "magick-image")

  # Pure spatial matching
  result_spatial <- pixel_morph(
    imgA = tmpA, imgB = tmpB,
    mode = "exact",
    alpha = 0, beta = 1,
    show = FALSE
  )
  expect_s3_class(result_spatial, "magick-image")

  # Just verify both work without error
})

test_that("final frame is sharp (transport-only)", {
  skip_if_not_installed("magick")
  skip_if_not_installed("png")
  skip_if_not(exists("morph_pixel_level_cpp"))

  H <- 8; W <- 8
  # Create image with distinct colors
  imgA <- array(0, c(H, W, 3))
  imgA[1:4, 1:4, 1] <- 1.0  # Red quadrant
  imgA[5:8, 5:8, 3] <- 1.0  # Blue quadrant

  imgB <- array(0.5, c(H, W, 3))  # Gray

  tmpA <- withr::local_tempfile(fileext = ".png")
  tmpB <- withr::local_tempfile(fileext = ".png")
  png::writePNG(imgA, tmpA)
  png::writePNG(imgB, tmpB)

  # Get final frame
  result <- pixel_morph(
    imgA = tmpA, imgB = tmpB,
    mode = "exact",
    show = FALSE
  )

  # Convert back to array to check for sharpness
  result_arr <- as.numeric(magick::image_data(result, channels = "rgb"))

  # Final frame should have mostly 0 or 1 values (sharp), not intermediate
  # Allow some tolerance for magick conversion
  n_intermediate <- sum(result_arr > 0.1 & result_arr < 0.9)
  n_total <- length(result_arr)
  
  # Less than 10% should be intermediate values
  expect_lt(n_intermediate / n_total, 0.1)
})