tests/testthat/test-scales-coltab.R

In tidyterra: 'tidyverse' Methods and 'ggplot2' Helpers for 'terra' Objects

test_that("Return NULL", {
  df <- data.frame(x = 1)
  expect_snapshot(res <- get_coltab_pal(df))
  expect_null(res)

  r <- terra::rast(system.file("extdata/cyl_elev.tif", package = "tidyterra"))

  expect_snapshot(res <- get_coltab_pal(r))
  expect_null(res)
})


test_that("Can extract a color table", {
  skip_on_cran()
  r <- terra::rast(system.file("extdata/cyl_era.tif", package = "tidyterra"))

  expect_true(terra::has.colors(r))

  pal <- get_coltab_pal(r)
  expect_named(pal)

  # Test equalities
  l <- pull(r, era) |> levels()

  expect_identical(names(pal), l)

  cls <- dplyr::bind_rows(terra::coltab(r))
  cats <- dplyr::bind_rows(terra::cats(r))
  names(cats) <- tolower(names(cats))
  end <- dplyr::left_join(cats[, c("value", "era")], cls, by = "value")
  morecols <- rgb(end[c("red", "green", "blue", "alpha")], maxColorValue = 255)
  expect_identical(unname(pal), morecols)
})

test_that("Can extract a color table on several layers", {
  skip_on_cran()
  rinit <- terra::rast(system.file(
    "extdata/cyl_era.tif",
    package = "tidyterra"
  ))

  expect_true(terra::has.colors(rinit))

  r2 <- terra::rast(rinit)
  terra::values(r2) <- rep_len(letters[1:3], terra::ncell(r2))
  levels(r2) <- NULL
  names(r2) <- "letter"
  r <- c(r2, rinit)
  expect_identical(terra::has.colors(r), c(FALSE, TRUE))

  pal <- get_coltab_pal(r)
  expect_named(pal)

  # Test equalities
  l2 <- pull(r, era) |> levels()
  l1 <- pull(r, letter) |>
    unique() |>
    sort()

  expect_identical(names(pal), c(l1, l2))
})

test_that("Can extract several color tables on layers", {
  skip_on_cran()
  # Prepare colors
  cols1 <- rainbow(3)
  cols2 <- c("#FFA500", "#FFFF00")

  # Prepare rasters
  r <- terra::rast(
    ncols = 4,
    nrows = 4,
    vals = as.factor(rep_len(c("A", "B", "A", "C"), 16))
  )
  r2 <- r
  terra::values(r2) <- as.factor(rep_len(c("S", "W", "S"), 16))

  # Add coltabs
  coltb1 <- data.frame(id = 1:3, t(col2rgb(cols1, alpha = TRUE)))
  coltb2 <- data.frame(id = 1:2, t(col2rgb(cols2, alpha = TRUE)))

  terra::coltab(r, layer = 1) <- coltb1
  terra::coltab(r2, layer = 1) <- coltb2

  rend <- c(r, r2)

  ctab1 <- get_coltab_pal(r)
  expect_true(all(cols1 == ctab1))

  ctab2 <- get_coltab_pal(r2)
  expect_true(all(cols2 == ctab2))

  ctab <- get_coltab_pal(rend)
  expect_identical(c(ctab1, ctab2), ctab)
})

test_that("Can alpha color tables", {
  skip_on_cran()
  # Prepare colors
  cols1 <- rainbow(3)
  cols2 <- ggplot2::alpha(c("#FFA500", "#FFFF00"), alpha = c(0.5, 0.7))

  # Prepare rasters
  r <- terra::rast(
    ncols = 4,
    nrows = 4,
    vals = as.factor(rep_len(c("A", "B", "A", "C"), 16))
  )
  r2 <- r
  terra::values(r2) <- as.factor(rep_len(c("S", "W", "S"), 16))

  # Add coltabs
  coltb1 <- data.frame(id = 1:3, t(col2rgb(cols1, alpha = TRUE)))
  coltb2 <- data.frame(id = 1:2, t(col2rgb(cols2, alpha = TRUE)))

  terra::coltab(r, layer = 1) <- coltb1
  terra::coltab(r2, layer = 1) <- coltb2

  rend <- c(r, r2)

  ctab1 <- get_coltab_pal(r)
  expect_true(all(cols1 == ctab1))

  ctab2 <- get_coltab_pal(r2)
  expect_true(all(cols2 == ctab2))
  ctab <- get_coltab_pal(rend)
  expect_true(all(
    # When mixed all colours have alpha, FF=100%
    c(paste0(ctab1, "FF"), ctab2) == ctab
  ))
})


test_that("Give informative messages", {
  skip_on_cran()
  df <- data.frame(x = 1)
  expect_snapshot(res <- get_coltab_pal(df))

  r <- terra::rast(system.file("extdata/cyl_elev.tif", package = "tidyterra"))

  expect_snapshot(res <- get_coltab_pal(r))
})


test_that("Discrete scale color", {
  skip_on_cran()
  r <- terra::rast(ncols = 4, nrows = 4)
  terra::values(r) <- as.factor(rep_len(c("A", "B", "A", "C"), 16))
  ll <- data.frame(id = 1:3, lev = c("A", "B", "C"))
  coltb <- data.frame(
    value = 1:3,
    t(col2rgb(c("red", "green", "black"), alpha = TRUE))
  )

  terra::coltab(r, layer = 1) <- coltb

  # Get levels
  d <- data.frame(
    x = 1:100,
    y = 1:100,
    ff = rev(rep_len(c("A", "C", "B", "A"), 100))
  )

  d$ff <- factor(d$ff, levels = c("A", "B", "C"))

  p <- ggplot2::ggplot(d) +
    ggplot2::geom_point(aes(x, y, colour = ff))

  init <- ggplot2::layer_data(p)$colour

  # On null do nothing
  expect_snapshot(pnull <- p + scale_color_coltab(data = terra::rast()))
  modnull <- ggplot2::layer_data(pnull)$colour

  expect_identical(init, modnull)

  # Add some NAs to df
  d2 <- d

  d2$ff[10:14] <- NA

  pnas <- ggplot2::ggplot(d2) +
    ggplot2::geom_point(aes(x, y, colour = ff)) +
    scale_color_coltab(data = r, na.translate = TRUE, na.value = "pink")

  modnas <- unique(sort(ggplot2::layer_data(pnas)$colour))
  nn <- sort(unname(c(get_coltab_pal(r), "pink")))

  expect_identical(nn, modnas)

  p2 <- p + scale_color_coltab(data = r)

  mod <- ggplot2::layer_data(p2)$colour
  expect_true(!any(init %in% mod))

  # Alpha
  expect_snapshot(p + scale_color_coltab(data = r, alpha = -1), error = TRUE)

  p3 <- p + scale_color_coltab(data = r, alpha = 0.9)

  mod_alpha <- ggplot2::layer_data(p3)$colour

  expect_true(all(alpha(mod, alpha = 0.9) == mod_alpha))

  # Alpha on coltab
  coltb2 <- coltb
  coltb2$alpha <- 100
  terra::coltab(r, layer = 1) <- coltb2

  p3 <- p + scale_color_coltab(data = r)

  thecols <- unique(ggplot2::layer_data(p3)$colour)

  df2 <- as.data.frame(t(col2rgb(thecols, alpha = TRUE)))
  expect_true(all(df2$alpha == 100))

  # Deactivate
  p5 <- p + scale_color_coltab(data = r, alpha = 0.56373)

  thecols <- unique(ggplot2::layer_data(p5)$colour)

  df2 <- as.data.frame(t(col2rgb(thecols, alpha = TRUE)))
  expect_false(any(df2$alpha == 100))
})


test_that("Discrete scale fill", {
  skip_on_cran()
  r <- terra::rast(ncols = 4, nrows = 4)
  terra::values(r) <- as.factor(rep_len(c("A", "B", "A", "C"), 16))
  ll <- data.frame(id = 1:3, lev = c("A", "B", "C"))
  coltb <- data.frame(
    value = 1:3,
    t(col2rgb(c("red", "green", "black"), alpha = TRUE))
  )
  terra::coltab(r, layer = 1) <- coltb

  # Get levels
  d <- as_tibble(r, xy = TRUE)
  names(d) <- c("x", "y", "ff")

  d$ff <- factor(d$ff, levels = c("A", "B", "C"))

  p <- ggplot2::ggplot(d) +
    ggplot2::geom_raster(aes(x, y, fill = ff))

  init <- ggplot2::layer_data(p)$fill

  # On null do nothing
  expect_snapshot(pnull <- p + scale_fill_coltab(data = terra::rast()))
  modnull <- ggplot2::layer_data(pnull)$fill

  expect_identical(init, modnull)

  # Add some NAs to df
  d2 <- d

  d2$ff[10:14] <- NA

  pnas <- ggplot2::ggplot(d2) +
    ggplot2::geom_point(aes(x, y, fill = ff)) +
    scale_fill_coltab(data = r, na.translate = TRUE, na.value = "pink")

  modnas <- unique(sort(ggplot2::layer_data(pnas)$fill))
  nn <- sort(unname(c(get_coltab_pal(r), "pink")))

  expect_identical(nn, modnas)

  p2 <- p + scale_fill_coltab(data = r)

  mod <- ggplot2::layer_data(p2)$fill
  expect_true(!any(init %in% mod))

  # Alpha
  expect_snapshot(p + scale_fill_coltab(data = r, alpha = -1), error = TRUE)

  p3 <- p + scale_fill_coltab(data = r, alpha = 0.9)

  mod_alpha <- ggplot2::layer_data(p3)$fill

  expect_true(all(alpha(mod, alpha = 0.9) == mod_alpha))

  # Alpha in coltab
  coltb2 <- coltb
  coltb2$alpha <- 31

  terra::coltab(r, layer = 1) <- coltb2

  p3 <- p + scale_fill_coltab(data = r)

  thecols <- unique(ggplot2::layer_data(p3)$fill)

  df2 <- as.data.frame(t(col2rgb(thecols, alpha = TRUE)))
  expect_true(all(df2$alpha == 31))

  # Deactivate
  p5 <- p + scale_fill_coltab(data = r, alpha = 0.56373)

  thecols <- unique(ggplot2::layer_data(p5)$fill)

  df2 <- as.data.frame(t(col2rgb(thecols, alpha = TRUE)))
  expect_false(any(df2$alpha == 31))
})

test_that("Several layers not all coltab", {
  skip_on_cran()
  r <- terra::rast(ncols = 4, nrows = 4)
  terra::values(r) <- as.factor(rep_len(c("A", "B"), 16))

  r$nocol <- as.factor(rep_len(c("D", "E", NA), 16))

  ll <- data.frame(id = 1:2, lev = c("A", "B"))
  coltb <- data.frame(
    value = 1:2,
    t(col2rgb(c("red", "yellow"), alpha = TRUE))
  )
  terra::coltab(r, layer = 1) <- coltb

  expect_identical(terra::has.colors(r), c(TRUE, FALSE))

  the_plot <- ggplot2::ggplot() +
    geom_spatraster(data = r) +
    ggplot2::facet_wrap(~lyr)

  expect_silent(gb <- ggplot2::ggplot_build(the_plot))

  guide <- ggplot2::get_guide_data(the_plot, "fill")

  allc <- rgb(t(col2rgb(c("red", "yellow"))), maxColorValue = 255)
  plus_col <- terrain.colors(2, rev = TRUE)
  expect_identical(guide$fill, c(allc, plus_col))

  colt <- unname(get_coltab_pal(r))
  expect_equal(colt, c(allc, plus_col))
})