tests/testthat/test-map-interface.R

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

local_edition(2)


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_equivalent(
            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_equivalent(
          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_equivalent(
    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_equivalent(text_color(ht2)[, 1], rep("green", 3))
  expect_silent(col2rgb(text_color(ht2)))

  expect_equivalent(
    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_equivalent(ht2, map_align(ht, 1:3, "a", br))

  skip_if_not_installed("dplyr")
  expect_equivalent(ht2, map_align(ht, 1:3, dplyr::matches("a"), br))
  expect_equivalent(ht2, map_align(ht, everywhere, dplyr::matches("a"), br))
  expect_equivalent(ht2, map_align(ht, everywhere, dplyr::starts_with("a"), br))
  expect_equivalent(ht2, map_align(ht, everywhere, -2, br))
  expect_equivalent(ht2, map_align(ht, everywhere, odds, br))

  ht3 <- map_align(ht, c(1, 3), 1:2, br)
  expect_equivalent(ht3, map_align(ht, -2, 1:2, br))
  expect_equivalent(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_equivalent(brdr_thickness(left_border(ht5))[1:3, 1],    c(1, 0, 2))
  expect_equivalent(brdr_thickness(top_border(ht5))[c(1, 3), 1],    c(1, 2))
  expect_equivalent(brdr_thickness(right_border(ht5))[1:3, 1],   c(1, 0, 2))
  expect_equivalent(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_equivalent(left_padding(ht6), 10 * (as.matrix(ht) >= 3))
  expect_equivalent(right_padding(ht6), 10 * (as.matrix(ht) >= 3))
})


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_equivalent(left_border_style(ht2)[, c(1, 3)], expected[, c(1, 3)])
  expect_equivalent(right_border_style(ht2)[, c(1, 3)], expected[, c(1, 3)])
  expect_equivalent(top_border_style(ht2), matrix("solid", 5, 3))
  expect_equivalent(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_equivalent(left_border_style(ht3), matrix("solid", 3, 2))
  expect_equivalent(right_border_style(ht3), matrix("solid", 3, 2))
  expect_equivalent(top_border_style(ht3)[c(1, 3),], expected[c(1, 3),])
  expect_equivalent(bottom_border_style(ht3)[c(1, 3),], expected[c(1, 3),])

})