tests/testthat/test-column_headers.R

In clinify: Clinical Table Styling Tools and Utilities

test_that("Errors checking", {
  # Proper target object
  expect_error(clin_column_headers(1), "inherits")

  # Proper argument types
  expect_error(clin_column_headers(clintable(iris), drat = 1), "All header arguments")


  # Proper column names
  expect_error(clin_column_headers(clintable(iris), blah = "blah"), "All argument names")
})

test_that("Headers apply as expected", {
  ct <- clintable(iris)

  ct2 <- ct |>
    clin_column_headers(
      Sepal.Length = c("Flowers", "Sepal", "Length"),
      Sepal.Width = c("Flowers", "Sepal", "Width"),
      Petal.Length = c("Petal", "Length"),
      Petal.Width = c("Petal", "Width"),
      Species = ""
    )

  # These snapshots capture the major factors of interest
  expect_snapshot(ct2$header$dataset) # Dup values applied in right spots
  expect_snapshot(ct2$header$spans) # Blank column spans don't merge with horizontals

  # Use iris
  refdat <- iris
  attr(refdat$Sepal.Length, "label") <- "Flower||Sepal||Length"
  attr(refdat$Sepal.Width, "label") <- "Flower||Sepal||Width"
  attr(refdat$Petal.Length, "label") <- "Flower||Petal||Length"
  attr(refdat$Petal.Width, "label") <- "Flower||Petal||Width"

  ct3 <- clintable(refdat)
  has_labels_(ct3$body$dataset)
  ct3 <- headers_from_labels_(ct3)
  expect_snapshot(ct3$header$dataset) # Dup values applied in right spots
  expect_snapshot(ct3$header$spans) # Blank column spans don't merge with horizontals

  # Test labels but also only use a single level
  refdat <- iris
  attr(refdat$Sepal.Length, "label") <- "Sepal Length"
  attr(refdat$Sepal.Width, "label") <- "Sepal Width"
  attr(refdat$Petal.Length, "label") <- "Petal Length"
  attr(refdat$Petal.Width, "label") <- "Petal Width"

  ct3 <- clintable(refdat)
  has_labels_(ct3$body$dataset)
  ct3 <- headers_from_labels_(ct3)
  expect_snapshot(ct3$header$dataset) # Dup values applied in right spots
  expect_snapshot(ct3$header$spans) # Blank column spans don't merge with horizontals
})

test_that("Overflowing page headers update appropriately", {
  dat <- mtcars
  dat["page"] <- c(
    rep(1, 10),
    rep(2, 10),
    rep(3, 10),
    c(4, 4)
  )
  dat2 <- rbind(dat, dat)
  dat2["groups1"] <- c(
    rep("a", 32),
    rep("b", 32)
  )
  dat2["groups2"] <- c(
    rep("1", 16),
    rep("2", 16),
    rep("1", 16),
    rep("2", 16)
  )

  ct <- clintable(dat2) |>
    clin_page_by("page") |>
    clin_group_by(c("groups1", "groups2")) |>
    clin_alt_pages(
      key_cols = c("mpg", "cyl", "hp"),
      col_groups = list(
        c("disp", "drat", "wt"),
        c("qsec", "vs", "am"),
        c("gear", "carb")
      )
    ) |>
    clin_column_headers(
      mpg = "Miles/(US) gallon",
      cyl = c("Number of cylinders"),
      disp = c("Displacement\n(cu.in.)"),
      hp = c("Gross horsepower"),
      drat = c("Span multiple pages", "Rear axle ratio"),
      wt = c("Span multiple pages", "Weight (1000 lbs)"),
      qsec = c("Span multiple pages", "1/4 mile time"),
      vs = c("Span multiple pages", "Engine\n(0 = V-shaped, 1 = straight)"),
      am = c("Span multiple pages", "Transmission\n(0 = automatic, 1 = manual)"),
      gear = c("Some Spanner", "Number of forward gears"),
      carb = c("Some Spanner", "Number of carburetors")
    )

  ct2 <- prep_pagination_(ct)

  pages <- ct2$clinify_config$pagination_idx
  p1_ind <- pages[[1]]
  p2_ind <- pages[[2]]
  p3_ind <- pages[[3]]

  p1 <- slice_clintable(ct2, p1_ind$rows, p1_ind$cols)
  p2 <- slice_clintable(ct2, p2_ind$rows, p2_ind$cols)
  p3 <- slice_clintable(ct2, p3_ind$rows, p3_ind$cols)

  expect_snapshot(p1$header$spans$rows)
  expect_snapshot(p1$header$dataset)
  expect_snapshot(p2$header$spans$rows)
  expect_snapshot(p2$header$dataset)
  expect_snapshot(p3$header$spans$rows)
  expect_snapshot(p3$header$dataset)
})