tests/testthat/test-independent-testing-as_rtf_pageby.R

library(dplyr)
svg(tempfile("tmp.svg"))
test_that("Test for case when output has title, footnote and source", {
  x <- iris[1:2, ] %>%
    rtf_title("Title") %>%
    rtf_footnote("Footnote") %>%
    rtf_source("DataSource") %>%
    rtf_body() %>%
    rtf_pageby(page_by = "Species", new_page = TRUE, pageby_header = TRUE) %>%
    as_rtf_pageby()

  expect_snapshot_output(x)
})

test_that("Test the pageby rows are the last rows of a page", {
  x <- iris %>%
    rtf_title("Title") %>%
    rtf_footnote("Footnote") %>%
    rtf_source("DataSource") %>%
    rtf_body() %>%
    rtf_pageby(page_by = "Species", new_page = TRUE, pageby_header = FALSE)

  y <- as.data.frame(attributes(as_rtf_pageby(x))) %>%
    group_by(info.id) %>%
    summarise_all(last) %>%
    mutate(row = substr(as.character(info.page), 1, 1))

  z <- as.data.frame(table(x$Species)) %>%
    mutate(cu = cumsum(Freq))
  z <- z %>% mutate(cum = cu + as.numeric(rownames(z)))

  expect_equal(y$row, rownames(y))
  expect_equal(y$info.index, z$cum)
  expect_false(all(y$info.pageby))
})

test_that("Test if border type/color for first/last row are assigned correctly", {
  x <- iris %>%
    rtf_body(
      border_first = c("single", "dash", "dot", "triple", ""),
      border_last = c("single", "dash", "dot", "triple", ""),
      border_color_top = c("black", "gold", "ivory", "blue", "white"),
      border_color_bottom = c("black", "gold", "ivory", "blue", "white"),
      border_color_first = c("azure", "gold", "ivory", "bisque", "white"),
      border_color_last = c("red", "gold", "ivory", "bisque", "white")
    ) %>%
    rtf_pageby(page_by = "Species", new_page = TRUE, pageby_header = TRUE) %>%
    as_rtf_pageby()

  attr(x, "info") <- NULL

  expect_snapshot_output(x[1])
})

test_that("Test if page_dict attribute is created for tbl", {
  x <- iris %>%
    rtf_body() %>%
    rtf_pageby(page_by = "Species", new_page = TRUE, pageby_header = FALSE)

  y <- as_rtf_pageby(x)

  expect_equal(names(attributes(y)), "info")
  if (interactive()) expect_snapshot_output(y)
})


test_that("Test for more than one page_by var", {
  x <- iris %>%
    mutate(cat = rep(1:5, 30)) %>%
    arrange(Species, cat) %>%
    rtf_page(nrow = 5) %>%
    rtf_body() %>%
    rtf_pageby(page_by = c("Species", "cat"), new_page = TRUE, pageby_header = TRUE)

  y <- as_rtf_pageby(x)
  expect_equal(names(attributes(y)), c("names", "info"))
  if (interactive()) expect_snapshot_output(y)
})


test_that("Test if new_page is FALSE and group_by is NOT NULL", {
  iris1 <- iris
  iris1$cat <- iris1$Species
  x <- iris1 %>%
    rtf_body(group_by = "cat") %>%
    rtf_pageby(page_by = "Species", new_page = FALSE, pageby_header = FALSE)
  y <- as_rtf_pageby(x)

  expect_equal(names(attributes(y)), "info")

  if (interactive()) expect_snapshot_output(y)
})

test_that("Test whether lines with '-----' were removed correctly", {
  x <- distinct(iris %>% subset(Species != "virginica"), Species, .keep_all = T) %>%
    mutate(Species = ifelse(Species == "setosa", "-----", Species)) %>%
    rtf_colheader("Sepal.Length | Sepal.Width | Petal.Length | Petal.Width",
      col_rel_width = rep(1, 4)
    ) %>%
    rtf_body(
      page_by = "Species",
      text_justification = c(rep("c", 4), "l"),
      border_top = c(rep("", 4), "single"),
      border_bottom = c(rep("", 4), "single")
    ) %>%
    rtf_encode()

  expect_snapshot_output(x$body)
})


test_that("Test when using subline_by and page_by together in rtf_body", {
  tbl1 <- iris[c(1:4, 51:54), 3:5] %>%
    mutate(s2 = paste0(Species, 1:2), s3 = s2) %>%
    arrange(Species, s2) %>%
    rtf_body(
      subline_by = "s2",
      page_by = "Species"
    ) %>%
    rtf_encode()

  expect_snapshot_output(tbl1$body)
})


test_that("Test when using subline_by and page_by with pageby_row = 'first_row' in rtf_body", {
  tbl2 <- iris[c(1:4, 51:54), 3:5] %>%
    mutate(s2 = paste0(Species, 1:2), s3 = s2) %>%
    arrange(Species, s2) %>%
    rtf_body(
      subline_by = "s2",
      page_by = "Species",
      pageby_row = "first_row"
    ) %>%
    rtf_encode()

  expect_snapshot_output(tbl2$body)
})

dev.off()

Try the r2rtf package in your browser

Any scripts or data that you put into this service are public.

r2rtf documentation built on Dec. 11, 2021, 9:08 a.m.