tests/testthat/test-heatmap.R

In clitable: Render Tables in Text for the Terminal

.heat_column <- 
test_that("heat_column", {
  local_reproducible_output(crayon = TRUE, unicode = TRUE)

  mat <- head(datasets::mtcars, 10)

  mat <- heat_column(mat, 1)
  mat <- heat_column(mat, "carb", ramp = grDevices::colorRamp(c("blue", "red")))
  mat <- heat_column(mat, "hp", xmin = 100, xmax = 110)

  expect_snapshot(cat(cli_table(mat), sep = "\n"))
})


.heatmap_nums <- 
test_that("heatmap_nums", {
  ### edge cases
  expect_identical(heatmap_nums(1), ansi_string(as.character("1")))
  expect_identical(heatmap_nums(c(1, NA)), ansi_string(as.character(c(1, NA))))

  local_reproducible_output(crayon = TRUE, unicode = TRUE)

  x <- c(0.1, 100, -2.5, 20, 78.2, NA)
  heated <- heatmap_nums(x)

  expect_s3_class(heated, "ansi_string")
  expect_length(heated, length(x))
  # check min
  expect_identical(heated[3], as.character(cell_bg(x[3], "green")))
  # check max
  expect_identical(heated[2], as.character(cell_bg(x[2], "red")))
  expect_snapshot(heated)
})



.scale_numeric <- 
test_that("scale_numeric_to_integer", {
  # standard
  x <- c(0.1, 100, -2.5, 20, 78.2, NA)
  scaled <- scale_numeric(x)
  expect_equal(scaled, (x - min(x, na.rm = TRUE)) / (max(x, na.rm = TRUE) - min(x, na.rm = TRUE)))

  # empty
  expect_equal(scale_numeric(numeric()), numeric())

  # singletons
  expect_equal(scale_numeric(0), 0.5)
  expect_equal(scale_numeric(1), 0.5)

  # NAs
  expect_equal(scale_numeric(NA_real_), NA_real_)
  expect_equal(scale_numeric(c(10, NA, 1)), c(1, NA, 0))
  expect_equal(scale_numeric(c(NA, -0.3)), c(NA, 0.5))

  # custom xmin, xmax
  scaled <- scale_numeric(x, xmin = 1, xmax = 80)
  
  expect_equal(scaled[1], 0)
  expect_equal(scaled[2], 1)
  expect_equal(scaled[3], 0)

  ref <- scaled * (80 - 1) + 1
  expect_equal(x[-(1:3)], ref[-(1:3)])
})


.cell_bg <- 
test_that("cell_bg", {
  local_reproducible_output(crayon = TRUE, unicode = TRUE)


  x <- cell_bg("red", "red")

  expect_s3_class(x, "ansi_string")
  expect_snapshot(cat(x))

  # rgb vector
  expect_identical(cell_bg("red", col2rgb("red")), x)

  # rgb spec
  expect_identical(cell_bg("red", col_to_rgbstring("red")), x)

  ### heatmap
  colors <- grDevices::colorRampPalette(c("green", "red"))(8)
  x <- sapply(seq_along(colors), \(i) cell_bg(i, colors[[i]]))
  
  expect_length(x, length(colors))
  expect_snapshot(cat(x, sep = ""))
})