tests/testthat/test-map-interface.R

In huxtable: Easily Create and Style Tables for LaTeX, HTML and Other Formats

local_edition(3)


test_that("Standard map_xxx", {
  ht <- huxtable(
    Type = c("Strawberry", "Raspberry", "Plum"),
    Price = c(1.90, 2.10, 1.80),
    add_colnames = FALSE
  )
  align(ht) <- "left"

  test_map <- function(map_fn, result, rows = 1:nrow(ht), cols = 1:ncol(ht)) {
    result <- strsplit(result, "")[[1]]
    result <- c("l" = "left", "c" = "center", "r" = "right")[result]
    expect_equal(
      unname(align(map_align(ht, rows, cols, map_fn))),
      matrix(result, nrow(ht), ncol(ht))
    )
  }

  test_map(
    by_cols("centre", "right"),
    "cccrrr"
  )
  test_map(by_cols("centre", "right"), "cclrrl", 1:2, 1:2)
  test_map(by_cols("right"), "lllrrr", 1:3, 2)

  test_map(by_rows("left", "centre", "right"), "lcrlcr")
  test_map(by_rows("left", "centre", "right"), "lcrlll", 1:3, 1)
  test_map(by_rows("right"), "llrllr", 3, 1:2)

  test_map(by_values(Strawberry = "right", Plum = "right", "centre"), "rcrccc")

  f <- function(x) ifelse(x == "Plum", "center", "right")
  test_map(by_function(f), "rrcrrr")

  test_map(by_regex(".*berry" = "right", "\\." = "centre"), "rrlccc")

  test_map(by_equal_groups(3, c("left", "centre", "right")), "lllcrl", 1:3, 2)
  test_map(by_quantiles(0.75, c("centre", "right")), "lllcrc", 1:3, 2)

  ht_2col <- hux(1:3, 4:6)
  expect_equal(
    unname(align(map_align(
      ht_2col,
      by_equal_groups(3, c("left", "center", "right"), colwise = TRUE)
    ))),
    matrix(rep(c("left", "center", "right"), 2), 3, 2)
  )
  expect_equal(
    unname(align(map_align(
      ht_2col,
      by_quantiles(c(.1, .9), c("left", "center", "right"), colwise = TRUE)
    ))),
    matrix(rep(c("left", "center", "right"), 2), 3, 2)
  )

  test_map(by_ranges(c(1.85, 2.05), c("left", "centre", "right")), "lllcrl", 1:3, 2)

  skip_if_not_installed("dplyr")

  test_map(
    by_cases(. == "Plum" ~ "centre", grepl("berry", .) ~ "right"),
    "rrclll"
  )

  skip_if_not_installed("scales")

  expect_silent(ht2 <- map_text_color(ht, by_colorspace("red", "yellow", na_color = "green")))
  expect_equal(as.vector(text_color(ht2)[, 1]), rep("green", 3))
  expect_silent(col2rgb(text_color(ht2)))

  expect_equal(
    unname(text_color(map_text_color(ht_2col, by_colorspace("red", "white", "blue", colwise = TRUE)))),
    matrix(rep(c("#FF0000", "#FFFFFF", "#0000FF"), 2), 3, 2)
  )
})


test_that("standard ways to mention columns work", {
  ht <- hux(a = 1:3, b = 1:3, add_colnames = TRUE)

  br <- by_rows("left", "centre", "right")
  ht2 <- map_align(ht, 1:3, 1, br)
  expect_equal(ht2, map_align(ht, 1:3, "a", br))

  skip_if_not_installed("dplyr")
  expect_equal(ht2, map_align(ht, 1:3, dplyr::matches("a"), br), ignore_attr = TRUE)
  expect_equal(ht2, map_align(ht, 1:3, dplyr::matches("a"), br))
  expect_equal(ht2, map_align(ht, 1:3, dplyr::starts_with("a"), br))
  expect_equal(ht2, map_align(ht, 1:3, -2, br))
  expect_equal(ht2, map_align(ht, 1:3, odds, br))

  ht3 <- map_align(ht, c(1, 3), 1:2, br)
  expect_equal(ht3, map_align(ht, -2, 1:2, br))
  expect_equal(ht3, map_align(ht, odds, 1:2, br))
})


test_that("map_all_*", {
  # we include the NAs because we don't make guarantees about
  # what happens when borders overlap!
  m <- matrix(c(1, NA, 2, NA, NA, NA, 2, NA, 1), 3, 3)
  ht <- as_huxtable(m)
  m1 <- !is.na(m) & m == 1
  m2 <- !is.na(m) & m == 2

  ht2 <- map_all_borders(ht, by_ranges(1.5, c(1, 2)))
  expect_true(all(brdr_thickness(left_border(ht2))[m1] == 1))
  expect_true(all(brdr_thickness(right_border(ht2))[m1] == 1))
  expect_true(all(brdr_thickness(top_border(ht2))[m1] == 1))
  expect_true(all(brdr_thickness(bottom_border(ht2))[m1] == 1))
  expect_true(all(brdr_thickness(left_border(ht2))[m2] == 2))
  expect_true(all(brdr_thickness(right_border(ht2))[m2] == 2))
  expect_true(all(brdr_thickness(top_border(ht2))[m2] == 2))
  expect_true(all(brdr_thickness(bottom_border(ht2))[m2] == 2))

  ht3 <- map_all_border_colors(ht, by_ranges(1.5, c("red", "black")))
  expect_true(all(left_border_color(ht3)[m1] == "red"))
  expect_true(all(right_border_color(ht3)[m1] == "red"))
  expect_true(all(top_border_color(ht3)[m1] == "red"))
  expect_true(all(bottom_border_color(ht3)[m1] == "red"))
  expect_true(all(left_border_color(ht3)[m2] == "black"))
  expect_true(all(right_border_color(ht3)[m2] == "black"))
  expect_true(all(top_border_color(ht3)[m2] == "black"))
  expect_true(all(bottom_border_color(ht3)[m2] == "black"))


  ht4 <- map_all_border_styles(ht, by_ranges(1.5, c("solid", "double")))
  expect_true(all(left_border_style(ht4)[m1] == "solid"))
  expect_true(all(right_border_style(ht4)[m1] == "solid"))
  expect_true(all(top_border_style(ht4)[m1] == "solid"))
  expect_true(all(bottom_border_style(ht4)[m1] == "solid"))
  expect_true(all(left_border_style(ht4)[m2] == "double"))
  expect_true(all(right_border_style(ht4)[m2] == "double"))
  expect_true(all(top_border_style(ht4)[m2] == "double"))
  expect_true(all(bottom_border_style(ht4)[m2] == "double"))

  ht5 <- map_all_borders(ht, 1:3, 1, by_ranges(1.5, c(1, 2)))
  expect_equal(as.vector(brdr_thickness(left_border(ht5))[1:3, 1]), c(1, 0, 2))
  expect_equal(as.vector(brdr_thickness(top_border(ht5))[c(1, 3), 1]), c(1, 2))
  expect_equal(as.vector(brdr_thickness(right_border(ht5))[1:3, 1]), c(1, 0, 2))
  expect_equal(as.vector(brdr_thickness(bottom_border(ht5))[c(1, 3), 1]), c(1, 2))

  ht <- as_huxtable(matrix(1:10, 5, 2))
  ht6 <- map_all_padding(ht, by_ranges(3, c(0, 10)))
  expect_equal(left_padding(ht6), 10 * (as.matrix(ht) >= 3), ignore_attr = TRUE)
  expect_equal(right_padding(ht6), 10 * (as.matrix(ht) >= 3), ignore_attr = TRUE)
})


test_that("map_lr/tb_*", {
  ht <- huxtable(1:5, rep(NA, 5), 5:1, add_colnames = FALSE)
  ht2 <- map_lr_border_styles(ht, by_ranges(3, c("solid", "double")))
  expected <- matrix(ifelse(as.matrix(ht) >= 3, "double", "solid"), 5, 3)
  expect_equal(unname(left_border_style(ht2)[, c(1, 3)]), unname(expected[, c(1, 3)]))
  expect_equal(unname(right_border_style(ht2)[, c(1, 3)]), unname(expected[, c(1, 3)]))
  expect_equal(unname(top_border_style(ht2)), matrix("solid", 5, 3))
  expect_equal(unname(bottom_border_style(ht2)), matrix("solid", 5, 3))

  ht <- huxtable(c(1, NA, 5), c(5, NA, 1))
  ht3 <- map_tb_border_styles(ht, by_ranges(3, c("solid", "double")))
  expected <- matrix(ifelse(as.matrix(ht) >= 3, "double", "solid"), 3, 2)
  expect_equal(unname(left_border_style(ht3)), matrix("solid", 3, 2))
  expect_equal(unname(right_border_style(ht3)), matrix("solid", 3, 2))
  expect_equal(unname(top_border_style(ht3)[c(1, 3), ]), unname(expected[c(1, 3), ]))
  expect_equal(unname(bottom_border_style(ht3)[c(1, 3), ]), unname(expected[c(1, 3), ]))
})